1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE DuplicateRecordFields #-}
6 ( someFunc, EntryList, allFilesIn, ProjectConfig
9 import Data.Function (on)
10 import Data.List (sort, sortBy, groupBy)
11 import Data.Ord (comparing)
12 import Data.String hiding (lines)
13 import Data.Text hiding (groupBy, map, concat, foldl, head, splitAt, filter, zip, length, reverse)
14 import Data.Text.Lazy (toStrict)
15 import Data.Text.Template
16 import Data.Time.Clock
17 import Data.Time.Clock.POSIX
18 import Data.Time.Format
19 import Data.Time.LocalTime
20 import Prelude hiding (lines)
21 import System.Directory
22 import System.FilePath.Posix (takeBaseName, takeDirectory)
27 name :: String, -- works better with getHomeDirectory
28 templates :: [(String, Template)]
31 data ProjectConfig = ProjectConfig {
34 theme :: String -- as above
35 } deriving (Show, Data, Typeable)
37 data Project = Project {
44 data BlogEntry = BlogEntry {
51 type EntryList = [(Text, [(Text, [(Text, BlogEntry)])])]
53 format t format = fromString $ formatTime defaultTimeLocale format $ utcToLocalTime (hoursToTimeZone 8) t
55 myGroup :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])]
56 myGroup = map (\l -> (fst . head $ l, map snd l)) . groupBy ((==) `on` fst) . sortBy (comparing fst)
58 myGroupNoSort :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])]
59 myGroupNoSort = map (\l -> (fst . head $ l, map snd l)) . groupBy ((==) `on` fst)
61 stampsToEntryList :: [BlogEntry] -> EntryList
62 stampsToEntryList stamps = map (\(a,b) -> (a, reverse $ map (\(c,d) -> (c, reverse $ map (\(x, y) -> ("0" `append` (fromString . show) x, y)) $ zip [1..] d)) b)) $
63 map (\(a, b) -> (a, myGroupNoSort b)) $
64 map (\(a, b) -> (a, concat b)) $ myGroupNoSort $
66 c ++ [(format (postDate v) "%Y", [(format (postDate v) "%B", v)])]) [] stamps
68 getEntriesTemplate :: Project -> Template
69 getEntriesTemplate p = case lookup "entry.html" $ templates $ theme (p :: Project) of
72 getEntriesVideoTemplate :: Project -> Template
73 getEntriesVideoTemplate p = case lookup "entry-video.html" $ templates $ theme (p :: Project) of
76 getTemplateForEntry :: Project -> BlogEntry -> Template
77 getTemplateForEntry p e = case video e of
78 Just _ -> getEntriesVideoTemplate p
79 Nothing -> getEntriesTemplate p
81 getIndexTemplate :: Project -> Template
82 getIndexTemplate p = case lookup "index.html" $ templates $ theme (p :: Project) of
85 getEntryPages :: Project -> [(Text, Text)]
86 getEntryPages p = concat $ concat $ map (\(year, months)
87 -> map (\(month, entries)
88 -> map (\(entryNum, entry) ->
91 format (postDate entry) "%Y",
92 format (postDate entry) "%B",
93 urlify (title entry) `append` ".html"],
94 entryToMarkup entry (getTemplateForEntry p entry))
95 ) entries) months) (entries p)
97 entryListToIndex :: EntryList -> Text
98 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
100 i2t :: Integer -> Text
101 i2t = (fromString . show)
103 slugify = toLower. replace " " "-"
104 urlify = slugify . replace "?" ""
106 timeStampToDateString = fromString . formatTime defaultTimeLocale "%d %B %Y" . utcToLocalTime (hoursToTimeZone 8)
108 entryToMarkup entry template = toStrict $ render template tmplContext
110 tmplContext = context $ [("title", title entry), ("date", timeStampToDateString $ postDate entry), ("body", body entry)] ++
113 Just a -> [("video", a)]
115 wrapInTags :: Text -> [Text] -> Text
116 wrapInTags tag = foldMap $ (<> close) . (open <>)
117 where close = "</" `append` tag `append` ">"
118 open = "<" `append` tag `append` ">"
120 paragraphs = wrapInTags "p"
122 unorderedList :: Maybe Text -> [Text] -> Text
123 unorderedList heading items = case heading of
124 Just x -> x `append` unorderedList Nothing items
125 Nothing -> "<ul>" `append` (wrapInTags "li" items) `append` "</ul>"
127 rawTextToEntry rawEntry = BlogEntry (posixSecondsToUTCTime (fromInteger (read (unpack $ meta !! 0)))) (meta !! 1) (paragraphs (snd (splitAt 1 fileLines))) (lookup 2 metaMap)
129 metaMap = zip [0..] meta
130 meta = splitOn "::" (fileLines !! 0)
131 fileLines = lines rawEntry
133 allFilesIn dir = filter (/= "..")<$>(filter(/= "."))<$>(getDirectoryContents dir)
135 someFunc projectConfig files = do
136 files <- fmap (reverse . sort) $ allFilesIn "entries"
137 rawEntries <- mapM (\x -> (readFile ("entries/" ++ x)) >>= (\y -> (return . fromString) y)) files
138 entryList <- mapM (\raw -> return $ rawTextToEntry raw) rawEntries
139 homeDir <- getHomeDirectory
141 let themeName = theme (projectConfig :: ProjectConfig)
142 themeTemplatePaths <- allFilesIn $ homeDir ++ "/.xyz/themes/" ++ themeName
143 themeTemplates <- mapM (\x -> (readFile $ homeDir ++ "/.xyz/themes/" ++ themeName ++ "/" ++ x) >>= (\y -> return (x, (template . fromString) y))) themeTemplatePaths
145 let projectName = name (projectConfig :: ProjectConfig)
146 let projectDescription = description (projectConfig :: ProjectConfig)
147 let project = Project projectName projectDescription (Theme themeName themeTemplates) (stampsToEntryList entryList)
149 mapM_ (createDirectoryIfMissing True . takeDirectory . unpack . fst) $ getEntryPages project
150 mapM_ (\x -> writeFile (unpack $ fst x) (unpack $ snd x)) $ getEntryPages project
151 writeFile "build/index.html" $ unpack $ toStrict $ render (getIndexTemplate project) $ context [("index", entryListToIndex (entries project))]
153 context :: [(Text, Text)] -> Context
154 context assocs x = case lookup x $ assocs of
155 Nothing -> "lol could not find that " `append` x