1 {-# LANGUAGE OverloadedStrings #-}
7 import Data.Function (on)
8 import Data.List (sortBy, groupBy)
9 import Data.Ord (comparing)
10 import Data.String hiding (lines)
11 import Data.Text hiding (groupBy, map, concat, foldl, head, splitAt, filter, zip, length, reverse)
12 import Data.Text.Lazy (toStrict)
13 import Data.Text.Template
14 import Data.Time.Clock
15 import Data.Time.Clock.POSIX
16 import Data.Time.Format
17 import Data.Time.LocalTime
18 import Prelude hiding (lines)
19 import System.Directory
20 import System.FilePath.Posix (takeBaseName)
22 data BlogEntry = BlogEntry {
29 type EntryList = [(Text, [(Text, [(Text, BlogEntry)])])]
31 format t format = fromString $ formatTime defaultTimeLocale format $ utcToLocalTime (hoursToTimeZone 8) t
33 myGroup :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])]
34 myGroup = map (\l -> (fst . head $ l, map snd l)) . groupBy ((==) `on` fst) . sortBy (comparing fst)
36 stampsToEntryList :: [BlogEntry] -> EntryList
37 stampsToEntryList stamps = reverse $ map (\(a,b) -> (a, reverse $ map (\(c,d) -> (c, map (\(x, y) -> ("0" `append` (fromString . show) x, y)) $ zip [1..] d)) b)) $
38 map (\(a, b) -> (a, myGroup b)) $
39 map (\(a, b) -> (a, concat b)) $ myGroup $
41 c ++ [(format (postDate v) "%Y", [(format (postDate v) "%B", v)])]) [] stamps
43 entryListToPaths :: EntryList -> [Text]
44 entryListToPaths el = concat $ concat $ map (\(year, months)
45 -> map (\(month, entries)
46 -> map (\(entryNum, entry) ->
49 month) entries) months) el
51 entryListToIndex :: EntryList -> Text
52 entryListToIndex el = unorderedList Nothing $ map (\(year, monthList) -> unorderedList (Just year) $ map (\(month, entryList) -> unorderedList (Just month) $ map (\x -> "<a href=\"" <> year <> "/" <> month <> "/" <> ((urlify . title . snd) x) <> ".html\">" <> (title . snd) x <> "</a>") entryList) monthList) el
54 i2t :: Integer -> Text
55 i2t = (fromString . show)
57 slugify = toLower. replace " " "-"
58 urlify = slugify . replace "?" ""
60 timeStampToDateString = fromString . formatTime defaultTimeLocale "%d %B %Y" . utcToLocalTime (hoursToTimeZone 8)
62 entryToMarkup entry template = toStrict $ render template tmplContext
64 tmplContext = context $ [("title", title entry), ("date", timeStampToDateString $ postDate entry), ("body", body entry)] ++
67 Just a -> [("video", a)]
69 wrapInTags :: Text -> [Text] -> Text
70 wrapInTags tag = foldMap $ (<> close) . (open <>)
71 where close = "</" `append` tag `append` ">"
72 open = "<" `append` tag `append` ">"
74 paragraphs = wrapInTags "p"
76 unorderedList :: Maybe Text -> [Text] -> Text
77 unorderedList heading items = case heading of
78 Just x -> x `append` unorderedList Nothing items
79 Nothing -> "<ul>" `append` (wrapInTags "li" items) `append` "</ul>"
81 rawTextToEntry rawEntry = BlogEntry (posixSecondsToUTCTime (fromInteger (read (unpack $ meta !! 0)))) (meta !! 1) (paragraphs (snd (splitAt 1 fileLines))) (lookup 2 metaMap)
83 metaMap = zip [0..] meta
84 meta = splitOn "::" (fileLines !! 0)
85 fileLines = lines rawEntry
87 allFilesIn dir = filter (/= "..")<$>(filter(/= "."))<$>(filter(/= ".gitignore"))<$>(getDirectoryContents dir)
89 exportEntry entry = do
90 rawTemplateNormal <- readFile "templates/entry.html"
91 rawTemplateVideo <- readFile "templates/entry-video.html"
93 let entryTemplate = template . pack $ case (video entry) of
94 Nothing -> rawTemplateNormal
95 Just a -> rawTemplateVideo
97 writeFile (unpack $ intercalate "/" [
99 format (postDate entry) "%Y",
100 format (postDate entry) "%B",
101 urlify (title entry) `append` ".html"]) $ unpack $ entryToMarkup entry entryTemplate
103 exportIndex :: EntryList -> IO()
104 exportIndex entryList = do
105 rawTemplate <- readFile "templates/index.html"
107 let indexTemplate = template . pack $ rawTemplate
108 let indexContext = context [("index", entryListToIndex entryList)]
110 writeFile "build/index.html" $ unpack $ toStrict $ render indexTemplate indexContext
113 files <- allFilesIn "entries"
114 rawEntries <- mapM (\x -> (readFile ("entries/" ++ x)) >>= (\y -> (return . fromString) y)) files
115 entryList <- mapM (\raw -> return $ rawTextToEntry raw) rawEntries
116 entryPaths <- return $ entryListToPaths $ stampsToEntryList entryList
117 mapM_ (createDirectoryIfMissing True . ("build/" ++) . unpack) entryPaths
118 mapM_ exportEntry entryList
119 exportIndex $ stampsToEntryList entryList
121 context :: [(Text, Text)] -> Context
122 context assocs x = case lookup x $ assocs of
123 Nothing -> "lol could not find that " `append` x