-- khjk.org website generator script -- copyright 2008-2009 Sven M. Hallberg -- all rights reserved import Text.Format.Cleartext import Text.Parsers.Frisby import Text.Parsers.Frisby.Char import Text.Regex import System.Directory import System.Cmd import System import Control.Monad import Control.Exception import Data.Char (ord, toUpper) import Data.List import Data.Time import Data.Maybe import Data.HashTable (hashInt) import Network.HTTP import Network.URI import qualified Base64 import Email sprueche = [ "Heute die Welt, morgen das Sonnensystem!" , "Mad science supplies at insane prices!" , "\"Raumflug!\"" , "\"GERMANIA 'Fabrikat'\"" , "Stand back! I'm going to try MAD SCIENCE!" , "Institute of applied mad sciences" , "Code without the crap" ] data Eintrag = Eintrag String Zeitangabe String Txt Doc [Comment] -- id, datum, autor, titel, inhalt, kommentare deriving Show data Comment = Comment Zeitangabe String Doc deriving Show type Project = String decl = "\n" doctype = "\n" xmlns = "http://www.w3.org/1999/xhtml" license = "http://creativecommons.org/licenses/by-nc-sa/3.0/" type Template = String -> String -> String -> String -- Title -> Meta -> Content -> HTML mkpage :: String -> [Project] -> [Eintrag] -> Template mkpage spruch projects log title hdmt content = decl ++ doctype ++ html where htitle | null title = "KHJK" | otherwise = "KHJK - " ++ xmlescape title html = "\n" ++ head ++ body ++ "\n" head = "\n\ \" ++ htitle ++ "\n\ \\n\ \\n\ \\n" ++ hdmt ++ "\n" body = "\n" ++ top ++ side ++ ctnt ++ foot ++ "\n" top = "

\n\ \

Karl Hans Janke Kollaborativ

\n\ \

" ++ spruch ++ "

\n\ \

\n" ctnt = "

\n" ++ content ++ "

\n" side = "\n" main = "

main

\n\ \front page
\n" proj = "

projects

\n" ++ projlinks projects arch = "

sympathies

\n\ \alex
\n\ \atari
\n\ \attraktor
\n\ \ccc
\n\ \ccc hamburg
\n\ \eisbaer
\n\ \hannes
\n\ \iso
\n\ \john
\n\ \ladyada
\n\ \malte
\n\ \shixi
\n" keyw = "KHJK, Karl Hans Janke, Programming, Coding, Hacking, Tinkering, Electronics, \ \Mad Science, Haskell, CCC, Chaos Computer Club, Hamburg, Attraktor, Weblog, \ \Photography" frontpage :: Template -> Int -> [Eintrag] -> String frontpage tmpl monat log = tmpl "" meta (concatMap eintrag frontlog) where meta = "\n\ \\n" frontlog = let (a,b) = splitAt 5 log in a ++ takeWhile thismon b thismon e = snd (yearmon e) == monat projlinks :: [Project] -> String projlinks = concatMap projlink . sort where projlink name = "" ++ xmlescape name ++ "
\n" archlinks :: [Eintrag] -> String archlinks = concatMap archlink . reverse . nub . sort . map yearmon where archlink (y,m) = "" ++ mnam ++ " " ++ show y ++ "
\n" where mnam = monthnames !! (m-1) fnam = "log/" ++ show y ++ "/" ++ mnam ++ ".html" yearmon (Eintrag _ (ZA (y:m:_)) _ _ _ _) = (y,m) monthnames = ["jan","feb","mar","apr","may","jun","jul", "aug","sep","oct","nov","dec"] archpage :: Template -> (Int,Int) -> [Eintrag] -> String archpage tmpl (y,m) log = tmpl titl "" ctnt where titl = mnam ++ " " ++ show y ctnt = "

" ++ titl ++ "

\n" ++ concatMap eintrag log mnam = monthnames !! (m-1) projpage :: Template -> Project -> Doc -> String projpage tmpl prj doc = tmpl prj "" (doctohtml doc) entpage :: Template -> (Maybe Eintrag, Eintrag, Maybe Eintrag) -> String entpage tmpl (ep,ent,en) = tmpl (txttoascii titel) "" content where Eintrag _ _ _ titel _ cs = ent content = prevnext ++ eintrag ent ++ comments prevnext = "

\n" ++ prev ++ next ++ "

\n" prev = "" ++ link ep tp ++ "\n" next = "" ++ link en tn ++ "\n" comments | null cs = "" | otherwise = "

\n" ++ cmthead ++ concatMap comment cs ++ replylink ent ++ "

\n" cmthead = "

Comments:

\n" tp = "<< prev" tn = "next >>" link Nothing _ = " " link (Just e) t = "" ++ t ++ "" replylink ent = "

>> reply

\n" replyaddress (Eintrag id _ _ title _ _) = "comment-" ++ deslash id ++ "@khjk.org?" ++ urlEncodeVars vs where deslash = map (\x -> if x=='/' then '.' else x) vs = [("subject", "Re: " ++ txttoascii title)] atom :: [Eintrag] -> String atom log = decl ++ feed where feed = "\n" ++ info ++ date ++ ents ++ "\n" info = "KHJK\n\ \Karl Hans Janke Kollaborativ\n\ \http://www.khjk.org/\n\ \\n\ \\n\ \\n\ \ Sven Moritz Hallberg\n\ \ sm@khjk.org\n\ \\n" ents = concatMap atomeintrag (take 10 log) date = case log of [] -> "" (Eintrag _ d _ _ _ _:_) -> "" ++ rfc3339date d ++ "\n" atomeintrag :: Eintrag -> String atomeintrag ent@(Eintrag id datum autor titel inhalt _) = concat ["\n", titletag, linktag, idtag, authortag, datetag, conttag, "\n"] where titletag = "" ++ xmlescape (txttohtml titel) ++ "\n" authortag = "\n\ \ " ++ xmlescape autor ++ "\n\ \ " ++ xmlescape autor ++ "@khjk.org\n\ \\n" linktag = "\n" datetag = "" ++ rfc3339date datum ++ "\n" conttag = "\n" ++ xmlescape (doctohtml inhalt) ++ "\n" idtag = "" ++ link ++ "\n" link = entrylink ent rss :: [Eintrag] -> String rss log = decl ++ "\n" ++ chan ++ "\n" where atom = "xmlns:atom='http://www.w3.org/2005/Atom'" chan = "\n" ++ info ++ date ++ ents ++ "\n" info = "KHJK\n\ \http://www.khjk.org/\n\ \Karl Hans Janke Kollaborativ\n\ \de\n\ \sm@khjk.org (Sven Moritz Hallberg)\n\ \\n" ents = concatMap rsseintrag (take 10 log) date = case log of [] -> "" (Eintrag _ d _ _ _ _:_) -> "" ++ rfc822date d ++ "\n\ \" ++ rfc822date d ++ "\n" rsseintrag :: Eintrag -> String rsseintrag ent@(Eintrag id datum autor titel inhalt _) = concat ["\n", titletag, linktag, desctag, authortag, guidtag, datetag, "\n"] where titletag = "" ++ xmlescape (txttohtml titel) ++ "\n" authortag = "" ++ xmlescape (autor ++ "@khjk.org (" ++ autor ++ ")") ++ "\n" linktag = "" ++ link ++ "\n" datetag = "" ++ rfc822date datum ++ "\n" desctag = "\n" ++ xmlescape (doctohtml inhalt) ++ "\n" guidtag = "" ++ link ++ "\n" link = entrylink ent eintrag :: Eintrag -> String eintrag ent@(Eintrag id datum autor titel inhalt cs) = "

\n" ++ uebschr ++ meta ++ text ++ cmtlink ++ replylink ent ++ "

\n" where uebschr = "

" ++ txttohtml titel ++ "

\n" meta = "

" ++ xmlescape (show datum) ++ ", " ++ autor ++ "

\n" text = doctohtml inhalt link = entrypath ent cmtlink | null cs = "" | otherwise = "

(" ++ show n ++ " comment" ++ (if n>1 then "s" else "") ++ "...)

\n" where n = length cs comment :: Comment -> String comment (Comment timestamp author content) = "

\n" ++ meta ++ body ++ "

\n" where meta = "

" ++ "" ++ xmlescape author ++ "" ++ time ++ "

\n" time = case timestamp of ZA [] -> "" _ -> "" ++ ", " ++ xmlescape (show timestamp) ++ "" body = "

\n" ++ doctohtml content ++ "

\n" xmlescape = concatMap (\c -> if c `elem` "<>&\"" then unirep c else [c]) unirep c = "&#" ++ show (ord c) ++ ";" -- datentyp fuer verschieden exakte zeitangeben newtype Zeitangabe = ZA [Int] -- felder: jahr, monat, tag, stunde, minute, ... instance Ord Zeitangabe where compare (ZA a) (ZA b) = uncurry compare (snip a b) where snip a b = unzip (zip a b) -- cuts lists down to be the same length instance Eq Zeitangabe where a == b = compare a b == EQ instance Show Zeitangabe where show (ZA [j,m,t]) = showdate j m t show (ZA [j,m,t,h,min]) = showdate j m t ++ " " ++ showhm h min show (ZA [j,m,t,h,min,s]) = showdate j m t ++ " " ++ showhms h min s showdate = showdate_ger showdate_iso j m t = show2 j ++ "-" ++ show2 m ++ "-" ++ show2 t showdate_ger j m t = show t ++ "." ++ show m ++ "." ++ show j show2 x = if x<10 then '0' : show x else show x showhm h m = show h ++ ":" ++ show2 m showhms h m s = showhm h m ++ ":" ++ show2 s show2hm h m = show2 h ++ ":" ++ show2 m show2hms h m s = show2hm h m ++ ":" ++ show2 s showdate_rfc j m t | m<1 || m>12 = error ("showdate_rfc: month (" ++ show m ++ ") out of bounds") | otherwise = show t ++ " " ++ month ++ " " ++ show j where month = toUpper x : xs (x:xs) = monthnames!!(m-1) -- the good old email timestamp format from 1982 rfc822date :: Zeitangabe -> String rfc822date (ZA [j,m,t]) = rfc822date (ZA [j,m,t,0,0]) rfc822date (ZA [j,m,t,h,min]) = showdate_rfc j m t ++ " " ++ show2hm h min ++ " GMT" rfc822date (ZA [j,m,t,h,min,s]) = showdate_rfc j m t ++ " " ++ show2hms h min s ++ " GMT" -- the fancy new timestamp format from 2002 rfc3339date :: Zeitangabe -> String rfc3339date (ZA [j,m,t]) = rfc3339date (ZA [j,m,t,0,0]) rfc3339date (ZA [j,m,t,h,min]) = rfc3339date (ZA [j,m,t,h,min,0]) rfc3339date (ZA [j,m,t,h,min,s]) = showdate_iso j m t ++ "T" ++ show2hms h min s ++ "Z" p_zeitangabe = do jahr <- newRule $ many1 digit ## read monat <- newRule $ max2 digit ## read tag <- newRule $ max2 digit ## read isodate <- newRule $ jahr <> char '-' ->> monat <<- char '-' <> tag ## \((j,m),t) -> [j,m,t] gerdate <- newRule $ tag <> char '.' ->> monat <<- char '.' <> jahr ## \((t,m),j) -> [j,m,t] amidate <- newRule $ monat <> char '/' ->> tag <<- char '/' <> jahr ## \((m,t),j) -> [j,m,t] datum <- newRule $ choice $ map (`onlyIf` validdate) [isodate, gerdate, amidate] stunden <- newRule $ (max2 digit ## read) `onlyIf` (<24) minuten <- newRule $ (max2 digit ## read) `onlyIf` (<60) sekunden <- newRule $ (max2 digit ## read) `onlyIf` (<60) uhrzeit <- newRule $ stunden ++> (char ':' ->> minuten) +/+ (char ':' ->> sekunden) +/+ unit [] za <- newRule $ many space ->> datum <++> option [] (many1 space ->> uhrzeit) <<- many space <<- eof return (za ## ZA) where infixr 3 +/+ infixr 3 ++> (+/+) :: P s a -> P s [a] -> P s [a] (++>) :: P s a -> P s [a] -> P s [a] a +/+ b = a <> option [] b ## uncurry (:) a ++> b = a <> b ## uncurry (:) max2 p = (p <> p ## \(x,y) -> [x,y]) // (p ## \x -> [x]) validdate [y,m,d] | y<1 = False | m<1 = False | m>12 = False | d<1 = False | d>monlen y m = False | otherwise = True monlen y m | m==2 = if leapyear then 29 else 28 | m`elem`[4,6,9,11] = 30 | otherwise = 31 where leapyear = y `mod` 4 == 0 && y `mod` 100 /= 0 parse_zeitangabe = runPeg peg where peg = do za <- p_zeitangabe return (za ## Just // unit Nothing) readEntry :: FilePath -> IO (Maybe Eintrag) readEntry f = do doc <- readctxfile f let metas = [ (k,v) | META k v <- doc ] datum = lookup "date" metas zeit = lookup "time" metas autor = lookup "author" metas titel = lookup "title" metas text = filter (not.ismeta) doc zad = datum >>= parse_zeitangabe :: Maybe Zeitangabe zaz = zeit >>= parse_zeitangabe :: Maybe Zeitangabe za = maybe zad Just zaz id = dropext f when (isNothing zeit && isNothing datum) $ putStrLn (f ++ ": missing time or date metatag") when (isNothing zeit && isJust datum && isNothing zad) $ putStrLn (f ++ ": unable to parse date metatag") when (isJust zeit && isNothing zaz) $ putStrLn (f ++ ": unable to parse time metatag") when (isNothing autor) $ putStrLn (f ++ ": missing author metatag") when (isNothing titel) $ putStrLn (f ++ ": missing title metatag") let mbox = dropext f ++ ".mbox" cs <- readcommentfile mbox let eintrag = do z <- za :: Maybe Zeitangabe a <- autor t <- titel return (Eintrag id z a (parsetxt t) text cs) when (isNothing eintrag) $ do putStrLn (f ++ ": ignored") return eintrag where ismeta (META _ _) = True ismeta _ = False dropext path | null path' = path -- no extension (no slashes) | head path' == '/' = path -- no extension (with slash) | null (tail path') = path -- dotfile (no slashes) | path'!!1 == '/' = path -- dotfile (with slash) | otherwise = reverse (tail path') where path' = dropWhile (\x -> x/='.' && x/='/') (reverse path) readcommentfile :: FilePath -> IO [Comment] readcommentfile f = do ex <- doesFileExist f mbox <- if ex then liftM mbox (readFile f) else return [] return (map email_to_comment mbox) email_to_comment :: Email -> Comment email_to_comment (hdrs,body) = Comment timestamp author doc where timestamp = maybe (ZA []) rfcdate_to_za (lookup "Date" hdrs) author = case liftM addressname (lookup "From" hdrs) of Nothing -> "anonymous" Just "" -> "anonymous" Just x -> x doc = parsedoc body addressname :: String -> String addressname addr = name where Emailaddress name _user _arg _domain = emailaddress addr rfcdate_to_za :: String -> Zeitangabe rfcdate_to_za str = ZA [y,m,d,h',min',s] where (cy, m') = divMod (m + cm) 12 (cm, d') = divMod (d + cd) (monlen y m) (cd, h') = divMod (h + zh + ch) 24 (ch, min') = divMod (min + zm) 60 (y,m,d,h,min,s,zh,zm) = read_rfcdate str entrylink e = "http://www.khjk.org/" ++ entrypath e twitterlink e = "http://khjk.org/" ++ entrypath e entrypath (Eintrag id _ _ _ _ _) = xmlescape id ++ ".html" -- replace Im tokens with thumbnails linked to the original autothumb :: Eintrag -> IO Eintrag autothumb (Eintrag id d a t doc cs) = do doc' <- mapM atbtok doc return $ Eintrag id d a t doc' cs where atbtok (TEXT txt) = do txt' <- mapM atltok txt return (TEXT txt') atbtok (FLOA mod doc cap) = do doc' <- mapM atbtok doc return (FLOA mod doc' cap) atbtok x = return x atltok (Im u) | "http://" `isPrefixOf` u = return (Im u) | ".klein.jpg" `isSuffixOf` u = return (Im u) | ".klein.png" `isSuffixOf` u = return (Im u) | otherwise = do ex <- doesFileExist uk unless ex $ do putStrLn ("> " ++ convcmd_k) system convcmd_k return () ex <- doesFileExist um unless ex $ do putStrLn ("> " ++ convcmd_m) system convcmd_m return () return (Hy [Im uk] um) where uk = subRegex (mkRegex "\\.[^.]+$") u ".klein\\0" um = subRegex (mkRegex "\\.[^.]+$") u ".medium\\0" convcmd_k = "convert " ++ u ++ " -scale 400 " ++ uk convcmd_m = "convert " ++ u ++ " -scale 1024 " ++ um atltok x = return x -- automatically post new log entries to twitter autotweet :: [Eintrag] -> IO () autotweet log = handle (\e -> print e) $ do lasttweet <- liftM (fromJust . parse_zeitangabe) (readFile "localstate/lasttweet") tweeters <- liftM read (readFile "localstate/tweeters") ms <- mapM (at1 tweeters) (takeWhile (after lasttweet) log) let xs = catMaybes ms when (not (null xs)) $ writeFile "localstate/lasttweet" (show (entdate (head xs))) where entdate (Eintrag _ d _ _ _ _) = d after za ent = entdate ent > za at1 tweeters ent@(Eintrag id _ autor title _ _) = case lookup autor tweeters of Nothing -> return Nothing Just u -> handle (\e -> print e >> return Nothing) $ do p <- readFile ("../authdata/twitter/" ++ u) putStrLn ("tweeting: " ++ u ++ ": " ++ tweettext) ok <- tweet u p tweettext return (if ok then Just ent else Nothing) where tweettext = tweettitle ++ ": " ++ link tweettitle | length asctitle <= titleroom = asctitle | otherwise = take (titleroom - 3) asctitle ++ "..." asctitle = txttoascii title titleroom = 138 - length link link = twitterlink ent tweet :: String -> String -> String -> IO Bool tweet user pass text = do res <- simpleHTTP req case res of Right rsp -> case rspCode rsp of (2,0,0) -> return True (a,b,c) -> putStrLn (show a++show b++show c++" "++rspReason rsp) >> return False Left err -> print err >> return False where req = Request { rqURI=uri, rqMethod=mth, rqHeaders=[aut], rqBody=bdy } mth = POST hst = URIAuth { uriUserInfo = "" , uriRegName = "twitter.com" , uriPort = "" } uri = URI { uriScheme = "http:" , uriAuthority = Just hst , uriPath = "/statuses/update.json" , uriQuery = "?" ++ urlEncodeVars [("status",text)] , uriFragment = "" } bdy = "" aut = Header HdrAuthorization ("Basic " ++ base64 (user ++ ":" ++ pass)) base64 = Base64.encode . map (fromIntegral . ord) -- no unicode! main = do args <- getArgs let publish = (args == ["publish"]) if publish then (putStrLn "publish mode - will interact with web services.") else (putStrLn "review mode - will not interact with web services.") filenames <- findlogentries eintraege <- liftM catMaybes $ mapM readEntry filenames eintraege' <- mapM autothumb eintraege projects <- findprojects t <- getCurrentTime let log = sortBy neuster eintraege' (jahr,monat,tag) = toGregorian (utctDay t) toint x = fromIntegral (x `mod` fromIntegral (maxBound :: Int)) :: Int woche = toint $ (utctDay t `diffDays` fromGregorian 2009 1 1) `div` 7 spruchnum = toint (hashInt woche) `mod` length sprueche spruch = sprueche!!spruchnum template = mkpage spruch projects log writeentries template log writearchive template log writeprojectpages template projects putStrLn "writing atom.xml" writeFile "atom.xml" (atom log) putStrLn "writing rss.xml" writeFile "rss.xml" (rss log) putStrLn ("writing index.html -- " ++ spruch) writeFile "index.html" (frontpage template monat log) when publish (autotweet log) neuster :: Eintrag -> Eintrag -> Ordering neuster (Eintrag _ d1 _ _ _ _) (Eintrag _ d2 _ _ _ _) = compare d2 d1 writeprojectpages tmpl = mapM_ write1 where write1 prj = do let ft = "prj/" ++ prj ++ "/index.txt" fh = "prj/" ++ prj ++ "/index.html" ex <- doesFileExist ft when ex $ do doc <- readctxfile ft putStrLn ("writing " ++ fh) writeFile fh (projpage tmpl prj doc) writearchive tmpl = mapM_ write1 . groupBy cmpyearmon where cmpyearmon a b = yearmon a == yearmon b write1 log = do putStrLn ("writing " ++ fnam) writeFile fnam (archpage tmpl (y,m) log) where (y,m) = yearmon (head log) fnam = "log/" ++ show y ++ "/" ++ mnam ++ ".html" mnam = monthnames !! (m-1) writeentries tmpl log = mapM_ (writeentpage tmpl) log_pcn where log_pcn = zip3 prevs log nexts nexts = Nothing : jlog prevs = tail jlog ++ [Nothing] jlog = map Just log writeentpage tmpl (ep,ent,en) = do putStrLn ("writing " ++ fnam ++ cmts) writeFile fnam (entpage tmpl (ep,ent,en)) where fnam = entrypath ent Eintrag _ _ _ _ _ cs = ent cmts | null cs = "" | otherwise = " (" ++ show (length cs) ++ " comments)" findprojects = search "prj" where search dir = do putStr ("scanning " ++ dir ++ "... ") xs <- getDirectoryContents dir let xs' = [ x | x<-xs, head x /= '.' ] dirs <- filterM isdir xs' putStrLn (show (length dirs) ++ " entries") return dirs where isdir x = doesDirectoryExist (dir ++ "/" ++ x) findlogentries = search "log" where search dir = do putStr ("scanning " ++ dir ++ "... ") xs <- getDirectoryContents dir let xs' = [ dir ++ "/" ++ x | x<-xs, head x /= '.' ] (dirs,files) <- partitionM doesDirectoryExist xs' let files' = [ f | f<-files, ".txt" `isSuffixOf` f ] putStrLn (show (length files') ++ " entries") yss <- mapM search dirs return (concat yss ++ files') partitionM p [] = return ([],[]) partitionM p (x:xs) = do t <- p x (ys,zs) <- partitionM p xs return (if t then (x:ys,zs) else (ys,x:zs))