src/Lib.hs

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