root/lang/haskell/blosxkel/blosxkel.hs @ 1158

#!/usr/local/bin/runghc
-- id:nobsun さんありがとうございます

module Main where

import System.FilePath
import System.Directory
import System.Time
import System.Locale (defaultTimeLocale)

import Data.List
import Data.Maybe
import Data.Char
import Data.Eq

import Network.CGI

import Text.Regex


-- ref. http://i.loveruby.net/ja/stdhaskell/samples/lazylines/Template.hs.html
fillFlavour :: String -> String -> [(String, String)] -> IO String
fillFlavour flavour place params = return . fill =<< (readFile $ place ++ "." ++ flavour)
    where
        fill ""   = ""
        fill tmpl = case break (== '$') tmpl of
                         (s, ('$':cs)) -> s ++ expand var ++ fill cont
                                          where (var, cont) = span isAlpha cs
                         (s, cont)     -> s ++ fill cont

        expand var = fromMaybe ('$':var) (lookup var params)


data Entry = Entry {
    file  :: FilePath,
    path  :: String,
    title :: String,
    time  :: ClockTime,
    body  :: [String]
}


getFileEntry :: String -> FilePath -> IO Entry
getFileEntry d f = do
    {
    ; mtime <- getModificationTime f
    ; cs    <- readFile f
    ; case lines cs of
        h:tl -> return $ Entry { file  = f
                               , path  = dropExtension $ drop (length d) f
                               , title = h
                               , time  = mtime
                               , body  = tl
                               }
    }

-- http://www.tom.sfc.keio.ac.jp/~sakai/2ch/1162902266.html
getRecursiveContents :: FilePath -> IO [FilePath]
getRecursiveContents fp = getDirectoryContents fp >>= mapM (fx fp) >>= return . concat
    where
       fx :: FilePath -> FilePath -> IO [FilePath]
       fx bp "."  = return [bp]
       fx bp ".." = return []
       fx bp f    = do let np = bp ++ ('/':f)
                       b <- doesDirectoryExist np
                       if b then getRecursiveContents np
                            else return [np]



getTextFileEntries :: FilePath -> IO [Entry]
getTextFileEntries d = do
    {
    ; fs <- getRecursiveContents d
    ; es <- mapM (getFileEntry d) $ filter (isSuffixOf ".txt") fs
    ; return es
    }


getResult :: [(String, String)] -> IO (String, String)
getResult cgiparams = do
    {
    ; entries <- getTextFileEntries "data"
    ; ct <- fill "content_type" []
    ; ch <- fill "head" []
    ; cs <- mapM
               (\e -> fill "story"
               [("title", title e),
                ("body", concat (body e)),
                ("time", formatCalendarTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" (toUTCTime (time e))),
                ("path", path e)])
               $ take 7 $ reverse $ sortBy (\a b -> compare (time a) (time b)) entries
    ; cf <- fill "foot" []
    ; return $ (ct, concat $ [ch, concat cs, cf])
    } where
        fill place params = fillFlavour "html" place (params ++ [("title", "Blosxkel.hs"),
                                                                 ("version", "aaa")] ++ cgiparams)

cgiMain :: CGI CGIResult
cgiMain =  do
    {
    ; home <- scriptName
    ; pathinfo <- pathInfo
    ; result <- liftIO $ getResult [("home", home), ("pathinfo", pathinfo)]
    ; setHeader "Content-Type" $ fst result
    ; output $ snd result
    }

main :: IO ()
main =  runCGI $ handleErrors cgiMain