{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
module Inf.Templates
( main
, page
, list
, login
, edit
, post
, delete
, Main(..)
, dbException
, someException
, markdown
, InternalError(..)
) where
import qualified Control.Exception as Exn
import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import Data.Monoid ((<>))
import qualified Data.Text as TS
import qualified Data.Text.Lazy as T
import qualified Text.Mustache as Stache
import qualified Text.Pandoc.Class as Pandoc
import qualified Text.Pandoc.Extensions as Pandoc
import qualified Text.Pandoc.Highlighting as Pandoc
import qualified Text.Pandoc.Options as Pandoc
import qualified Text.Pandoc.Readers.Markdown as Pandoc
import qualified Text.Pandoc.Writers.HTML as Pandoc
import Inf.Types
class InternalError t where
renderedError :: t -> IO T.Text
loggedError :: t -> String
instance InternalError DBException where
renderedError = dbException
loggedError = show
instance InternalError Exn.SomeException where
renderedError = someException
loggedError = show
instance InternalError Unimplemented where
renderedError (Unimplemented _) = main Main
{ mainUser = Nothing
, mainTitle = "Unimplemented"
, mainContents = "IMPLEMENT ME"
, mainUrl = "/"
}
loggedError (Unimplemented msg) = "Unimplemented: " ++ msg
markdownOpts :: Pandoc.ReaderOptions
markdownOpts = Pandoc.def
{ Pandoc.readerExtensions = Pandoc.pandocExtensions
}
htmlOpts :: Pandoc.WriterOptions
htmlOpts = Pandoc.def
{ Pandoc.writerHighlightStyle = Just Pandoc.tango
}
markdown :: TS.Text -> IO TS.Text
markdown raw = Pandoc.runIOorExplode $ do
pandoc <- Pandoc.readMarkdown markdownOpts raw
Pandoc.writeHtml5String htmlOpts pandoc
data Main = Main
{ mainUser :: !(Maybe TS.Text)
, mainTitle :: !T.Text
, mainContents :: !T.Text
, mainUrl :: !TS.Text
}
main :: Main -> IO T.Text
main Main { mainUser, mainTitle, mainContents, mainUrl } = do
template <- Stache.compileMustacheFile "templates/main.mustache"
let vals = Aeson.object
[ "title" .= mainTitle
, "contents" .= mainContents
, "user" .= case mainUser of
Nothing -> Aeson.toJSON ()
Just u -> Aeson.object [ "name" .= u ]
, "url" .= mainUrl
]
pure (Stache.renderMustache template vals)
login :: IO T.Text
login = do
template <- Stache.compileMustacheFile "templates/login.mustache"
pure (Stache.renderMustache template (Aeson.object []))
page :: TS.Text -> IO T.Text
page contents = do
template <- Stache.compileMustacheFile "templates/page.mustache"
mk <- markdown contents
let vals = Aeson.object
[ "contents" .= mk ]
pure (Stache.renderMustache template vals)
nullable :: Maybe a -> (a -> [(TS.Text, Aeson.Value)]) -> Aeson.Value
nullable Nothing _ = Aeson.toJSON ()
nullable (Just x) k = Aeson.object (k x)
post :: Maybe TS.Text -> Post -> IO T.Text
post user ps = do
template <- Stache.compileMustacheFile "templates/post.mustache"
mk <- markdown (postContents ps)
let vals = Aeson.object
[ "contents" .= mk
, "user" .= nullable user (\_ ->
[ "editurl" .= (postURL ps <> "/edit")
, "delurl" .= (postURL ps <> "/delete")
])
, "next" .= nullable (postNext ps) (\nxt ->
[ "link" .= postRefURL nxt ])
, "prev" .= nullable (postPrev ps) (\nxt ->
[ "link" .= postRefURL nxt ])
]
pure (Stache.renderMustache template vals)
edit :: TS.Text -> RawPost -> IO T.Text
edit url ps = do
template <- Stache.compileMustacheFile "templates/edit.mustache"
let vals = Aeson.object
[ "id" .= maybe "" (show . fromPostId) (rpId ps)
, "title" .= rpTitle ps
, "author" .= userName (rpAuthor ps)
, "contents" .= rpContents ps
, "url" .= url
]
pure (Stache.renderMustache template vals)
delete :: Post -> IO T.Text
delete ps = do
template <- Stache.compileMustacheFile "templates/delete.mustache"
let vals = Aeson.object
[ "post_url" .= postURL ps
]
pure (Stache.renderMustache template vals)
list :: [PostRef] -> IO T.Text
list posts = do
template <- Stache.compileMustacheFile "templates/list.mustache"
let vals = Aeson.object
[ "posts" .=
[ Aeson.object [ "url" .= postRefURL ref
, "title" .= prName ref
, "date" .= postRefDateT ref
]
| ref <- posts
]
]
pure (Stache.renderMustache template vals)
dbException :: DBException -> IO T.Text
dbException exn = do
contents <- page $ TS.unlines
( "## Internal server error"
: case exn of
NoSuchPost -> [ "database misconfiguration" ]
BadUserError -> [ "bad user session" ]
NonUniqueResult -> [ "database misconfiguration" ]
MissingPost pId -> [ "missing post: `" <> TS.pack (show pId) <> "`"]
MissingPage name -> [ "missing page: `" <> name <> "`"]
NoPostFound year month slug ->
[ "no such post: `" <> year <> "/" <> month <> "/" <> slug <> "`" ]
)
main Main
{ mainUser = Nothing
, mainTitle = "Error"
, mainContents = contents
, mainUrl = "/"
}
someException :: Exn.SomeException -> IO T.Text
someException exn = do
contents <- page $ TS.unlines
[ "The following unexpected error occurred:"
, "```"
, TS.pack (show exn)
, "```"
]
main Main
{ mainUser = Nothing
, mainTitle = "Internal Server Error"
, mainContents = contents
, mainUrl = "/"
}