acatalepsie/src/Posts.hs

module Posts where

import Data.Aeson.Types (FromJSON)
import Data.Binary      (Binary, put, get)
import Data.Time        (UTCTime, defaultTimeLocale)
import Data.Time.Clock  (getCurrentTime)
import Data.Time.Format (rfc822DateFormat, formatTime)
import Data.List        (isPrefixOf)
import Data.Foldable    (for_)
import Data.Text        (unpack)
import GHC.Generics
import Lucid hiding (for_)

import Text.Atom.Feed   as Atom
import Text.Feed.Types  (Feed(..))
import Text.Feed.Export (textFeed)
import qualified Achille.Internal.IO as AchilleIO

import Common
import Config (ropts, wopts)
import Visual (Image(..))
import qualified Config
import Templates
import Route
import System.FilePath
import System.Directory ( setCurrentDirectory
                        , getTemporaryDirectory
                        , renameDirectory
                        , createDirectoryIfMissing
                        )
import Math

--  metadata used for parsing YAML headers
data PostMeta = PostMeta
    { title       :: Text
    , date        :: Text
    , draft       :: Maybe Bool
    , description :: Maybe Text
    } deriving (Generic, Eq, Show, FromJSON)

data Post = Post
    { postTitle       :: Text
    , postDate        :: UTCTime
    , postDraft       :: Bool
    , postDescription :: Maybe Text
    , postContent     :: Text
    , postPath        :: FilePath
    } deriving (Generic, Eq, Show, Binary)

instance IsTimestamped Post where timestamp = postDate

(-<..>) = replaceExtensions

buildPost :: FilePath -> Task IO Post
buildPost src = do
    copyFile src
    let ext = takeExtensions src
    if ".lagda.md" `isPrefixOf` ext then processAgda src
    else do
        (PostMeta title date draft desc, pandoc) <- readPandocMetadataWith ropts src
        pandoc' <- pure pandoc -- processMath pandoc
        content <- renderPandocWith wopts pandoc'
        let time = timestamp (unpack date)
        rendered <- pure (renderPost time title content)
        write (dropExtensions src </> "index.html") rendered
        write (src -<..> "html") rendered
          <&> Post title time (fromMaybe False draft) Nothing content

    where
        processAgda :: FilePath -> Task IO Post
        processAgda src = do
            spath  <- toAbsolute src
            odir   <- getOutputDir <&> (</> dropExtensions src)
            tmpdir <- liftIO getTemporaryDirectory <&> (</> "achille")
            liftIO $ createDirectoryIfMissing False tmpdir
            liftIO $ createDirectoryIfMissing False odir
            liftIO $ AchilleIO.copyFile spath (tmpdir </> "index.lagda.md")

            -- agda --html needs to be invoked in the correct directory
            liftIO $ setCurrentDirectory tmpdir

            callCommand $
                "agda --html "
                <> "--html-dir=. "
                <> "--html-highlight=auto "
                <> "index.lagda.md"

            callCommand $ "cp " <> tmpdir <> "/* " <> odir

            let tpath = odir </> "index.md"

            (PostMeta title date draft desc, pandoc) <- readAbsPandocMetadataWith ropts tpath
            content <- renderPandocWith wopts pandoc
            let time = timestamp (unpack date)
            pure (renderPost time title content)
                >>= write (dropExtensions src </> "index.html")
                <&> takeDirectory
                <&> Post title time (fromMaybe False draft) Nothing content


build :: Bool -> [Image] -> Task IO ()
build showDrafts imgs = do
    posts <- match "posts/*" buildPost
             <&> filter (\p -> not (postDraft p) || showDrafts)
             <&> recentFirst

    watch imgs $ watch posts $ match_ "index.rst" \src -> do
        compilePandoc src
            <&> renderIndex imgs posts
            >>= write (src -<..> "html")

        now <- liftIO getCurrentTime
        let (Just feed) = textFeed (AtomFeed $ postsToFeed now posts)
        write "atom.xml" feed

    where
        postsToFeed now posts =
            ( Atom.nullFeed
                "https://acatalepsie.fr/atom.xml"
                (Atom.TextString "acatalepsie")
                "2017-08-01")
            { Atom.feedEntries = postToEntry <$> posts
            , Atom.feedUpdated = fromString $ toDate now
            }

        postToEntry :: Post -> Atom.Entry
        postToEntry post =
            ( Atom.nullEntry (fromString $ postPath post)
                             (Atom.TextString $ postTitle post)
                             (fromString $ toDate $ postDate post))
            { Atom.entryContent = Just $ Atom.HTMLContent $ postContent post
            , Atom.entrySummary = Atom.HTMLString <$> postDescription post
            }


renderPost :: UTCTime -> Text -> Text -> Html ()
renderPost date title content =
    outerWith def { Config.title = title, Config.route = PostRoute } do
        header_ do
            p_ do time_ $ toHtml (showDate date)
            h1_ $ toHtml title
        toHtmlRaw content


renderIndex :: [Image] -> [Post] -> Text -> Html ()
renderIndex imgs posts content = 
    outer do
        toHtmlRaw content

        section_ [class_ "visual tiny"] $
            for_ imgs \Image{..} ->
                figure_ $ a_ [href_ $ fromString imgPath] $ img_
                    [ src_ (fromString imgThumbPath)
                    , width_ (fromString $ show imgThumbWidth)
                    , height_ (fromString $ show imgThumbHeight)
                    ]

        ul_ [ id_ "pidx" ] $ forM_ posts \post ->
            li_ do
                span_ $ fromString $ showDate (postDate post)
                toLink (postPath post) (toHtml $ postTitle post)