src/Lib.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module Lib
   4     ( someFunc
   5     ) where
   6
   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)
  21
  22 data BlogEntry = BlogEntry {
  23   postDate :: UTCTime,
  24   title :: Text,
  25   body :: Text,
  26   video :: Maybe Text
  27   } deriving (Show)
  28
  29 type EntryList = [(Text, [(Text, [(Text, BlogEntry)])])]
  30
  31 format t format = fromString $ formatTime defaultTimeLocale format $ utcToLocalTime (hoursToTimeZone 8) t
  32
  33 myGroup :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])]
  34 myGroup = map (\l -> (fst . head $ l, map snd l)) . groupBy ((==) `on` fst)
  35
  36 stampsToEntryList :: [BlogEntry] -> EntryList
  37 stampsToEntryList stamps = 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 $
  40                            foldl (\c -> \v ->
  41                                      c ++ [(format (postDate v) "%Y", [(format (postDate v) "%B", v)])]) [] stamps
  42
  43 entryListToPaths :: EntryList -> [Text]
  44 entryListToPaths el = concat $ concat $ map (\(year, months)
  45                                      -> map (\(month, entries)
  46                                              -> map (\(entryNum, entry) ->
  47                                                        year `append`
  48                                                        "/" `append`
  49                                                        month) entries) months) el
  50
  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 <> "/" <> ((slugify . title . snd) x) <>  ".html\">" <> (title . snd) x <> "</a>") entryList) monthList) el
  53
  54 i2t :: Integer -> Text
  55 i2t = (fromString . show)
  56
  57 slugify = toLower. replace " " "-"
  58
  59 timeStampToDateString = fromString . formatTime defaultTimeLocale "%d %B %Y" . utcToLocalTime (hoursToTimeZone 8)
  60
  61 entryToMarkup entry template = toStrict $ render template tmplContext
  62   where
  63     tmplContext = context $ [("title", title entry), ("date", timeStampToDateString $ postDate entry), ("body", body entry)] ++
  64       case video entry of
  65         Nothing -> []
  66         Just a -> [("video", a)]
  67
  68 wrapInTags :: Text -> [Text] -> Text
  69 wrapInTags tag = foldMap $ (<> close) . (open <>)
  70   where  close = "</" `append` tag `append` ">"
  71          open = "<" `append` tag `append` ">"
  72
  73 paragraphs = wrapInTags "p"
  74
  75 unorderedList :: Maybe Text -> [Text] -> Text
  76 unorderedList heading items = case heading of
  77   Just x -> x `append` unorderedList Nothing items
  78   Nothing -> "<ul>" `append` (wrapInTags "li" items) `append` "</ul>"
  79
  80 rawTextToEntry rawEntry = BlogEntry (posixSecondsToUTCTime (fromInteger (read (unpack $ meta !! 0)))) (meta !! 1) (paragraphs (snd (splitAt 1 fileLines))) (lookup 2 metaMap)
  81   where
  82     metaMap = zip [0..] meta
  83     meta = splitOn "::" (fileLines !! 0)
  84     fileLines = lines rawEntry
  85
  86 allFilesIn dir = filter (/= "..")<$>(filter(/= "."))<$>(filter(/= ".gitignore"))<$>(getDirectoryContents dir)
  87
  88 exportEntry entry = do
  89   rawTemplateNormal <- readFile "templates/entry.html"
  90   rawTemplateVideo <- readFile "templates/entry-video.html"
  91
  92   let entryTemplate = template . pack $ case (video entry) of
  93         Nothing -> rawTemplateNormal
  94         Just a -> rawTemplateVideo
  95
  96   writeFile (unpack $ intercalate "/" [
  97                 "build",
  98                 format (postDate entry) "%Y",
  99                 format (postDate entry) "%B",
 100                 slugify (title entry) `append` ".html"]) $ unpack $ entryToMarkup entry entryTemplate
 101
 102 exportIndex :: EntryList -> IO()
 103 exportIndex entryList = do
 104   rawTemplate <- readFile "templates/index.html"
 105
 106   let indexTemplate = template . pack $ rawTemplate
 107   let indexContext = context [("index", entryListToIndex entryList)]
 108
 109   writeFile "build/index.html" $ unpack $ toStrict $ render indexTemplate indexContext
 110
 111 someFunc = do
 112   files <- allFilesIn "entries"
 113   rawEntries <- mapM (\x -> (readFile ("entries/" ++ x)) >>= (\y -> (return . fromString) y)) files
 114   entryList <- mapM (\raw -> return $ rawTextToEntry raw) rawEntries
 115   entryPaths <- return $ entryListToPaths $ stampsToEntryList entryList
 116   mapM_ (createDirectoryIfMissing True . ("build/" ++) . unpack) entryPaths
 117   mapM_ exportEntry entryList
 118   exportIndex $ stampsToEntryList entryList
 119
 120 context :: [(Text, Text)] -> Context
 121 context assocs x = case lookup x $ assocs of
 122                      Nothing -> "lol could not find that " `append` x
 123                      Just a -> a