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

Revision 1169, 6.3 kB (checked in by jknaoya, 7 years ago)

lang/haskell/blosxkel/head.xml,
lang/haskell/blosxkel/blosxkel.hs:

atom がただしくなるようにしました。
バージョンを表示するようになりました。

  • Property svn:executable set to *
Line 
1#!/usr/local/bin/runghc
2-- id:nobsun さんありがとうございます
3
4module Main where
5
6import System.FilePath
7import System.Directory
8import System.Time
9import System.Locale (defaultTimeLocale)
10
11import System.Info
12import Data.Version
13
14import Data.List
15import Data.Maybe
16import Data.Char
17import Data.Eq
18
19import Network.CGI
20
21-- ref. http://i.loveruby.net/ja/stdhaskell/samples/lazylines/Template.hs.html
22fillFlavour :: String -> String -> [(String, String)] -> IO String
23fillFlavour flavour place params = return . fill =<< (readFile $ place ++ flavour)
24    where
25        fill ""   = ""
26        fill tmpl = case break (== '$') tmpl of
27                         (s, ('$':cs)) -> s ++ expand var ++ fill cont
28                                          where (var, cont) = span isAlpha cs
29                         (s, cont)     -> s ++ fill cont
30
31        expand var = fromMaybe ('$':var) (lookup var params)
32
33loadConfig :: String -> IO [(String, String)]
34loadConfig config = do
35    {
36    ; c <- readFile config
37    ; return $ concatMap parseLine $ lines c
38    } where
39        parseLine :: String -> [(String, String)]
40        parseLine l
41                  | all isSpace l = []
42                  | otherwise     = let (k, (':':v)) = (break (== ':') l)
43                                    in [(strip k, strip v)]
44        strip     = rstrip . lstrip
45        rstrip    = reverse . lstrip . reverse
46        lstrip    = dropWhile isSpace
47
48getConfig :: [(String, String)] -> String -> String
49getConfig config key = fromJust $ lookup key config
50
51data Entry = Entry {
52    file  :: FilePath,
53    path  :: String,
54    title :: String,
55    time  :: ClockTime,
56    body  :: [String]
57}
58
59
60getFileEntry :: String -> FilePath -> IO Entry
61getFileEntry d f = do
62    {
63    ; mtime <- getModificationTime f
64    ; cs    <- readFile f
65    ; case lines cs of
66        h:tl -> return $ Entry { file  = f
67                               , path  = dropExtension $ drop (length d) f
68                               , title = h
69                               , time  = mtime
70                               , body  = tl
71                               }
72    }
73
74-- http://www.tom.sfc.keio.ac.jp/~sakai/2ch/1162902266.html
75getRecursiveContents :: FilePath -> IO [FilePath]
76getRecursiveContents fp = getDirectoryContents fp >>= mapM (fx fp) >>= return . concat
77    where
78       fx :: FilePath -> FilePath -> IO [FilePath]
79       fx bp "."  = return [bp]
80       fx bp ".." = return []
81       fx bp f    = do let np = bp ++ ('/':f)
82                       b <- doesDirectoryExist np
83                       if b then getRecursiveContents np
84                            else return [np]
85
86
87
88getTextFileEntries :: FilePath -> IO [Entry]
89getTextFileEntries d = do
90    {
91    ; fs <- getRecursiveContents d
92    ; es <- mapM (getFileEntry d) $ filter (isSuffixOf ".txt") fs
93    ; return es
94    }
95
96strftime = formatCalendarTime defaultTimeLocale
97strfctime format ct = strftime format (toUTCTime ct)
98
99filterByPathInfo :: String -> [Entry] -> [Entry]
100filterByPathInfo pathinfo entries
101    | length spath == 2 &&
102      all isDigit (spath !! 1) = filter (\e -> (strfctime "/%Y"       (time e)) == joinPath spath) entries
103    | length spath == 3 &&
104      all isDigit (spath !! 1) = filter (\e -> (strfctime "/%Y/%m"    (time e)) == joinPath spath) entries
105    | length spath == 4 &&
106      all isDigit (spath !! 1) = filter (\e -> (strfctime "/%Y/%m/%d" (time e)) == joinPath spath) entries
107    | otherwise                = filter (\e -> isPrefixOf (joinPath spath) (path e)) entries
108    where
109        spath | takeFileName pathi == "index" = splitDirectories $ dropFileName pathi
110              | otherwise                     = splitDirectories pathi
111        pathi = dropExtension pathinfo
112
113getResult :: [(String, String)] -> [(String, String)] -> IO (String, String)
114getResult cgiparams config = do
115    {
116    ; entries <- getTextFileEntries $ getConfig config "data-dir"
117    ; ct <- fill "content_type" []
118    ; ch <- fill "head" [("lastupdate", strfctime "%Y-%m-%dT%H:%M:%SZ"
119                                        (time $ maximumBy (\a b -> compare (time a) (time b)) entries))]
120    ; cs <- mapM
121               (\e -> fill "story"
122               [("title"  , title e),
123                ("body"   , concat (body e)),
124                ("time"   , strfctime "%Y-%m-%dT%H:%M:%SZ" (time e)),
125                ("yr"     , strfctime "%Y"  (time e)),
126                ("mo"     , strfctime "%b"  (time e)),
127                ("mo_num" , strfctime "%m"  (time e)),
128                ("da"     , strfctime "%d"  (time e)),
129                ("dw"     , strfctime "%a"  (time e)),
130                ("hr"     , strfctime "%H"  (time e)),
131                ("min"    , strfctime "%M"  (time e)),
132                ("hr12"   , strfctime "%I"  (time e)),
133                ("ampm"   , strfctime "%p"  (time e)),
134                ("ti"     , strfctime "%X"  (time e)),
135                ("fn"     , path e),
136                ("path"   , path e)])
137               $ take 7 $ reverse $ sortBy (\a b -> compare (time a) (time b))
138               $ filterByPathInfo (fromJust $ lookup "pathinfo" cgiparams) entries
139    ; cf <- fill "foot" []
140    ; return $ (ct, concat $ [ch, concat cs, cf])
141    } where
142        fill place params = fillFlavour (getConfig cgiparams "flavour") place
143                                        (params ++ [("title"  , getConfig config "title"),
144                                        ("author" , getConfig config "author"),
145                                        ("version", unwords [os, arch, compilerName, showVersion compilerVersion])] ++ cgiparams)
146
147cgiMain :: CGI CGIResult
148cgiMain =  do
149    {
150    ; config     <- liftIO $ loadConfig "config"
151    ; home       <- scriptName
152    ; pathinfo   <- pathInfo
153    ; servername <- serverName
154    ; flavour    <- return $ takeExtension pathinfo
155    ; (ct, cb)   <- liftIO $ getResult [("home", home),
156                                        ("pathinfo", pathinfo),
157                                        ("servername", "http://" ++ servername),
158                                        ("flavour", if length flavour == 0
159                                                    then getConfig config "default-flavour"
160                                                    else flavour)] config
161    ; setHeader "Content-Type" $ reverse $ dropWhile isSpace $ reverse $ ct
162    ; output $ cb
163    }
164
165main :: IO ()
166main =  runCGI $ handleErrors cgiMain
167
Note: See TracBrowser for help on using the browser.