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

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

module Main where

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

import System.Info
import Data.Version

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
    }

strftime = formatCalendarTime defaultTimeLocale
strfctime format ct = strftime format (toUTCTime ct)

filterByPathInfo :: String -> [Entry] -> [Entry]
filterByPathInfo pathinfo entries
    | length spath == 2 &&
      all isDigit (spath !! 1) = filter (\e -> (strfctime "/%Y"       (time e)) == joinPath spath) entries
    | length spath == 3 &&
      all isDigit (spath !! 1) = filter (\e -> (strfctime "/%Y/%m"    (time e)) == joinPath spath) entries
    | length spath == 4 &&
      all isDigit (spath !! 1) = filter (\e -> (strfctime "/%Y/%m/%d" (time e)) == joinPath spath) entries
    | otherwise                = filter (\e -> isPrefixOf (joinPath spath) (path e)) entries
    where
        spath | takeFileName pathi == "index" = splitDirectories $ dropFileName pathi
              | otherwise                     = splitDirectories pathi
        pathi = dropExtension pathinfo

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" [("lastupdate", strfctime "%Y-%m-%dT%H:%M:%SZ"
                                        (time $ maximumBy (\a b -> compare (time a) (time b)) entries))]
    ; cs <- mapM
               (\e -> fill "story"
               [("title"  , title e),
                ("body"   , concat (body e)),
                ("time"   , strfctime "%Y-%m-%dT%H:%M:%SZ" (time e)),
                ("yr"     , strfctime "%Y"  (time e)),
                ("mo"     , strfctime "%b"  (time e)),
                ("mo_num" , strfctime "%m"  (time e)),
                ("da"     , strfctime "%d"  (time e)),
                ("dw"     , strfctime "%a"  (time e)),
                ("hr"     , strfctime "%H"  (time e)),
                ("min"    , strfctime "%M"  (time e)),
                ("hr12"   , strfctime "%I"  (time e)),
                ("ampm"   , strfctime "%p"  (time e)),
                ("ti"     , strfctime "%X"  (time e)),
                ("fn"     , path e),
                ("path"   , path e)])
               $ take 7 $ reverse $ sortBy (\a b -> compare (time a) (time b))
               $ filterByPathInfo (fromJust $ lookup "pathinfo" cgiparams) entries
    ; cf <- fill "foot" []
    ; return $ (ct, concat $ [ch, concat cs, cf])
    } where
        fill place params = fillFlavour (getConfig cgiparams "flavour") place
                                        (params ++ [("title"  , getConfig config "title"),
                                        ("author" , getConfig config "author"),
                                        ("version", unwords [os, arch, compilerName, showVersion compilerVersion])] ++ cgiparams)

cgiMain :: CGI CGIResult
cgiMain =  do
    {
    ; config     <- liftIO $ loadConfig "config"
    ; home       <- scriptName
    ; pathinfo   <- pathInfo
    ; servername <- serverName
    ; flavour    <- return $ takeExtension pathinfo
    ; (ct, cb)   <- liftIO $ getResult [("home", home),
                                        ("pathinfo", pathinfo),
                                        ("servername", "http://" ++ servername),
                                        ("flavour", if length flavour == 0
                                                    then getConfig config "default-flavour"
                                                    else flavour)] config
    ; setHeader "Content-Type" $ reverse $ dropWhile isSpace $ reverse $ ct
    ; output $ cb
    }

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