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

#!/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

-- 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)

loadConfig :: String -> IO [(String, String)]
loadConfig config = do
    {
    ; c <- readFile config
    ; return $ concatMap parseLine $ lines c
    } where
        parseLine :: String -> [(String, String)]
        parseLine l
                  | all isSpace l = []
                  | otherwise     = let (k, (':':v)) = (break (== ':') l)
                                    in [(strip k, strip v)]
        strip     = rstrip . lstrip
        rstrip    = reverse . lstrip . reverse
        lstrip    = dropWhile isSpace

getConfig :: [(String, String)] -> String -> String
getConfig config key = fromJust $ lookup key config

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)] -> [(String, String)] -> IO (String, String)
getResult cgiparams config = do
    {
    ; entries <- getTextFileEntries $ getConfig config "data-dir"
    ; 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))),
                ("yr"     , formatCalendarTime defaultTimeLocale "%Y" (toUTCTime (time e))),
                ("mo"     , formatCalendarTime defaultTimeLocale "%b" (toUTCTime (time e))),
                ("mo_num" , formatCalendarTime defaultTimeLocale "%m" (toUTCTime (time e))),
                ("da"     , formatCalendarTime defaultTimeLocale "%d" (toUTCTime (time e))),
                ("dw"     , formatCalendarTime defaultTimeLocale "%a" (toUTCTime (time e))),
                ("hr"     , formatCalendarTime defaultTimeLocale "%H" (toUTCTime (time e))),
                ("min"    , formatCalendarTime defaultTimeLocale "%M" (toUTCTime (time e))),
                ("hr12"   , formatCalendarTime defaultTimeLocale "%I" (toUTCTime (time e))),
                ("ampm"   , formatCalendarTime defaultTimeLocale "%p" (toUTCTime (time e))),
                ("ti"     , formatCalendarTime defaultTimeLocale "%X" (toUTCTime (time e))),
                ("fn"     , path 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"  , getConfig config "title"),
                                                                 ("author" , getConfig config "author"),
                                                                 ("version", "How I can get this version of GHC in program?")] ++ cgiparams)

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

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