src/Lib.hs

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