src/Lib.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE DuplicateRecordFields #-}
   4
   5 module Lib
   6     ( someFunc, EntryList, allFilesIn, ProjectConfig
   7     ) where
   8
   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)
  23 import Data.Data
  24 import Data.Typeable
  25
  26 data Theme = Theme {
  27   name :: String, -- works better with getHomeDirectory
  28   templates :: [(String, Template)]
  29     } deriving (Show)
  30
  31 data ProjectConfig = ProjectConfig {
  32   name :: Text,
  33   description :: Text,
  34   theme :: String -- as above
  35   } deriving (Show, Data, Typeable)
  36
  37 data Project = Project {
  38   name :: Text,
  39   description :: Text,
  40   theme :: Theme,
  41   entries :: EntryList
  42   } deriving (Show)
  43
  44 data BlogEntry = BlogEntry {
  45   postDate :: UTCTime,
  46   title :: Text,
  47   body :: Text,
  48   video :: Maybe Text
  49   } deriving (Show)
  50
  51 type EntryList = [(Text, [(Text, [(Text, BlogEntry)])])]
  52
  53 format t format = fromString $ formatTime defaultTimeLocale format $ utcToLocalTime (hoursToTimeZone 8) t
  54
  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)
  57
  58 myGroupNoSort :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])]
  59 myGroupNoSort = map (\l -> (fst . head $ l, map snd l)) . groupBy ((==) `on` fst)
  60
  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 $
  65                            foldl (\c -> \v ->
  66                                      c ++ [(format (postDate v) "%Y", [(format (postDate v) "%B", v)])]) [] stamps
  67
  68 getEntriesTemplate :: Project -> Template
  69 getEntriesTemplate p = case lookup "entry.html" $ templates $ theme (p :: Project) of
  70   Just a -> a
  71
  72 getEntriesVideoTemplate :: Project -> Template
  73 getEntriesVideoTemplate p = case lookup "entry-video.html" $ templates $ theme (p :: Project) of
  74   Just a -> a
  75
  76 getTemplateForEntry :: Project -> BlogEntry -> Template
  77 getTemplateForEntry p e = case video e of
  78   Just _ -> getEntriesVideoTemplate p
  79   Nothing -> getEntriesTemplate p
  80
  81 getIndexTemplate :: Project -> Template
  82 getIndexTemplate p = case lookup "index.html" $ templates $ theme (p :: Project) of
  83   Just a -> a
  84
  85 getEntryPages :: Project -> [(Text, Text)]
  86 getEntryPages p = concat $ concat $ map (\(year, months)
  87                                      -> map (\(month, entries)
  88                                              -> map (\(entryNum, entry) ->
  89                                                        (intercalate "/" [
  90                                                            "build",
  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)
  96
  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
  99
 100 i2t :: Integer -> Text
 101 i2t = (fromString . show)
 102
 103 slugify = toLower. replace " " "-"
 104 urlify = slugify . replace "?" ""
 105
 106 timeStampToDateString = fromString . formatTime defaultTimeLocale "%d %B %Y" . utcToLocalTime (hoursToTimeZone 8)
 107
 108 entryToMarkup entry template = toStrict $ render template tmplContext
 109   where
 110     tmplContext = context $ [("title", title entry), ("date", timeStampToDateString $ postDate entry), ("body", body entry)] ++
 111       case video entry of
 112         Nothing -> []
 113         Just a -> [("video", a)]
 114
 115 wrapInTags :: Text -> [Text] -> Text
 116 wrapInTags tag = foldMap $ (<> close) . (open <>)
 117   where  close = "</" `append` tag `append` ">"
 118          open = "<" `append` tag `append` ">"
 119
 120 paragraphs = wrapInTags "p"
 121
 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>"
 126
 127 rawTextToEntry rawEntry = BlogEntry (posixSecondsToUTCTime (fromInteger (read (unpack $ meta !! 0)))) (meta !! 1) (paragraphs (snd (splitAt 1 fileLines))) (lookup 2 metaMap)
 128   where
 129     metaMap = zip [0..] meta
 130     meta = splitOn "::" (fileLines !! 0)
 131     fileLines = lines rawEntry
 132
 133 allFilesIn dir = filter (/= "..")<$>(filter(/= "."))<$>(getDirectoryContents dir)
 134
 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
 140
 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
 144
 145   let projectName = name (projectConfig :: ProjectConfig)
 146   let projectDescription = description (projectConfig :: ProjectConfig)
 147   let project = Project projectName projectDescription (Theme themeName themeTemplates) (stampsToEntryList entryList)
 148
 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))]
 152
 153 context :: [(Text, Text)] -> Context
 154 context assocs x = case lookup x $ assocs of
 155                      Nothing -> "lol could not find that " `append` x
 156                      Just a -> a