-- khjk.org website generator script -- copyright 2008-2009 Sven M. Hallberg -- all rights reserved (aka "just ask") 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.OldException import Data.Char (ord, toUpper, isSpace) import Data.List import Data.Time import Data.Maybe import Data.HashTable (hashInt) import Numeric (showHex) 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" , "Inventing wheels since 2005" ] data Eintrag = Eintrag String Zeitangabe String Txt Doc [Comment] -- id, datum, autor, titel, inhalt, kommentare deriving Show entryid (Eintrag x _ _ _ _ _) = x entryauthor (Eintrag _ _ x _ _ _) = x entrytitle (Eintrag _ _ _ x _ _) = x entrytext (Eintrag _ _ _ _ x _) = x 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 type UIDs = [(String,String)] -- mapping author names to user ids mkpage :: String -> [Project] -> [Eintrag] -> Template mkpage spruch projects log title hdmt content = decl ++ doctype ++ html where htitle | null title = "KHJK" | otherwise = "KHJK - " ++ xml_escape title html = "\n" ++ head ++ body ++ "\n" head = "\n\ \" ++ htitle ++ "\n\ \\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 :: UIDs -> Template -> Int -> [Eintrag] -> String frontpage fu tmpl monat log = tmpl "" meta (concatMap (eintrag fu) 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 = "" ++ xml_escape name ++ "
\n" projurl :: Project -> String projurl name = "http://www.khjk.org/prj/" ++ name 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 :: UIDs -> Template -> (Int,Int) -> [Eintrag] -> String archpage fu tmpl (y,m) log = tmpl titl "" ctnt where titl = mnam ++ " " ++ show y ctnt = "

" ++ titl ++ "

\n" ++ concatMap (eintrag fu) log mnam = monthnames !! (m-1) projpage :: UIDs -> Template -> Project -> Doc -> String projpage fu tmpl prj doc = tmpl prj "" (doctohtml doc) -- ++ proj_flattrbtn fu prj doc) proj_flattrbtn :: UIDs -> Project -> Doc -> String proj_flattrbtn uids prj doc = case lookup "flattr" meta of Just uid -> flattrbtn "default" (maybe uid id (lookup uid uids)) (if null title then [St prj] else title) (docdesc doc) (maybe "software" id (lookup "category" meta)) (doclang doc) ("khjk" : doctags doc) (projurl prj) Nothing -> "" where meta = metadata doc title = doctitle' doc entpage :: UIDs -> Template -> (Maybe Eintrag, Eintrag, Maybe Eintrag) -> String entpage fu tmpl (ep,ent,en) = tmpl (txttoascii titel) "" content where Eintrag _ _ _ titel _ cs = ent content = prevnext ++ eintrag fu 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 = "" ++ xml_escape (txttohtml titel) ++ "\n" authortag = "\n\ \ " ++ xml_escape autor ++ "\n\ \ " ++ xml_escape autor ++ "@khjk.org\n\ \\n" linktag = "\n" datetag = "" ++ rfc3339date datum ++ "\n" conttag = "\n" ++ xml_escape (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 = "" ++ xml_escape (txttohtml titel) ++ "\n" authortag = "" ++ xml_escape (autor ++ "@khjk.org (" ++ autor ++ ")") ++ "\n" linktag = "" ++ link ++ "\n" datetag = "" ++ rfc822date datum ++ "\n" desctag = "\n" ++ xml_escape (doctohtml inhalt) ++ "\n" guidtag = "" ++ link ++ "\n" link = entrylink ent eintrag :: UIDs -> Eintrag -> String eintrag uids ent@(Eintrag id datum autor titel inhalt cs) = "

\n" ++ uebschr ++ meta ++ text -- ++ entry_flattrbtn uids ent ++ cmtlink -- ++ replylink ent ++ "

\n" where uebschr = "

" ++ txttohtml titel ++ "

\n" meta = "

" ++ xml_escape (show datum) ++ ", " ++ autor ++ (if null tags then "" else "
tags: " ++ tags) ++ "

\n" text = doctohtml inhalt link = entrypath ent tags = unwords (entrytags ent) cmtlink | null cs = "" | otherwise = "

(" ++ show n ++ " comment" ++ (if n>1 then "s" else "") ++ xml_escape [ellipsis] ++ ")

\n" where n = length cs ellipsis = '\x2026' readflattruids = liftM read (readFile "localstate/flattruids") entry_flattrbtn :: [(String,String)] -> Eintrag -> String entry_flattrbtn uids e = case lookup author uids of Just uid -> flattrbtn "compact" uid (entrytitle e) (docdesc doc) "text" (doclang doc) ("khjk" : "blog" : author : doctags doc) (entrylink e) Nothing -> "" where doc = entrytext e author = entryauthor e flattrbtn :: String -> String -> Txt -> String -> String -> String -> [String] -> String -> String flattrbtn style uid title desc cat lang tags url = "

\n\ \\n\ \\n\ \

\n" where esc = xml_escape . jsstring taglist = concat (intersperse "," tags) entrypath e = xml_escape (entryid e) ++ ".html" entrylink e = "http://www.khjk.org/" ++ entrypath e entrytags = doctags . entrytext docabstract = liftM parsetxt . lookup "abstract" . metadata doctags = maybe [] words . lookup "tags" . metadata doclang = maybe "en_GB" lang . lookup "lang" . metadata where lang "en" = "en_GB" lang "de" = "de_DE" lang x = x doctitle' d = if null t then topheading d else t where t = doctitle d topheading d | null hs = [] -- no headings in document | n>m = [] -- top-level heading is not the first in document | otherwise = h where hs = [(h,n) | SECT n h <- d] (h,n) = head hs m = minimum (map snd hs) docdesc d = maybe (docpreview d) id (lookup "abstract" (metadata d)) docpreview = cut 400 . txttoascii . rep where -- preview representation of block tokens rep xs = concat (intersperse [St ell] [t | TEXT t <- xs]) -- cut off at first word boundary after at least n characters cut n xs = a ++ takeWhile (not.isSpace) b ++ ell where (a,b) = splitAt n xs ell = " [" ++ ellipsis : "] " jsstring xs = "'" ++ concatMap esc xs ++ "'" where esc c | c `elem` "\\'" = ['\\',c] | c == '\b' = "\\b" | c == '\f' = "\\f" | c == '\n' = "\\n" | c == '\r' = "\\r" | c == '\t' = "\\t" | otherwise = [c] comment :: Comment -> String comment (Comment timestamp author content) = "

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

\n" where meta = "

" ++ "" ++ xml_escape author ++ "" ++ time ++ "

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

\n" ++ doctohtml content ++ "

\n" -- taken from XmlOut.hs xml_escape, att_escape :: String -> String xml_escape = xml_escape' "<>&" att_escape = xml_escape' "<>&\"" xml_escape' escme = concatMap (\c -> if c `elem` escme || ord c > 127 then unirep c else [c]) where 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 = metadata doc datum = lookup "date" metas zeit = lookup "time" metas autor = lookup "author" metas titel = lookup "title" metas text = 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 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 twitterlink e = "http://khjk.org/" ++ entrypath e -- 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 ++ [ellipsis] 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 fu <- readflattruids 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 fu template log writearchive fu template log writeprojectpages fu 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 fu template monat log) --when publish (autotweet log) -- needs oauth now or something. neuster :: Eintrag -> Eintrag -> Ordering neuster (Eintrag _ d1 _ _ _ _) (Eintrag _ d2 _ _ _ _) = compare d2 d1 writeprojectpages fu 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 fu tmpl prj doc) writearchive fu tmpl = mapM_ write1 . groupBy cmpyearmon where cmpyearmon a b = yearmon a == yearmon b write1 log = do putStrLn ("writing " ++ fnam) writeFile fnam (archpage fu tmpl (y,m) log) where (y,m) = yearmon (head log) fnam = "log/" ++ show y ++ "/" ++ mnam ++ ".html" mnam = monthnames !! (m-1) writeentries fu tmpl log = mapM_ (writeentpage fu tmpl) log_pcn where log_pcn = zip3 prevs log nexts nexts = Nothing : jlog prevs = tail jlog ++ [Nothing] jlog = map Just log writeentpage fu tmpl (ep,ent,en) = do putStrLn ("writing " ++ fnam ++ cmts) writeFile fnam (entpage fu 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))