module Dixi.Server where
import Control.Monad.IO.Class
import Control.Monad.Trans.Either
import Data.Acid
import Data.Default
import Data.Time
import Data.Text (Text)
import Data.Traversable
import Servant
import Text.Pandoc
#ifdef OLDBASE
import Control.Applicative
#endif
import qualified Data.Text as T
import Dixi.API
import Dixi.Common
import Dixi.Config
import Dixi.Database
import Dixi.Forms ()
import Dixi.Markup (writePandocError, dixiError)
import Dixi.Page
spacesToUScores :: T.Text -> T.Text
spacesToUScores = T.pack . map (\x -> if x == ' ' then '_' else x) . T.unpack
page :: AcidState Database -> Renders -> Key -> Server PageAPI
page db renders (spacesToUScores -> key)
= latest
|: history
where
latest = latestQ pp |: latestQ rp
diffPages (Just v1) (Just v2) = liftIO (query db (GetDiff key (v1, v2)))
>>= \case Left e -> handle e
Right x -> return $ DP renders key v1 v2 x
diffPages _ _ = left err400
history = liftIO (H renders key <$> query db (GetHistory key))
|: version
|: diffPages
|: reversion
reversion (DR v1 v2 com) = do
_ <- liftIO (getCurrentTime >>= update db . Revert key (v1, v2) com)
latestQ pp
version v = (versionQ pp v |: versionQ rp v)
|: updateVersion v
updateVersion v (NB t c) = do _ <- liftIO (getCurrentTime >>= update db . Amend key v t c)
latestQ pp
latestQ :: (Key -> Version -> Page Text -> IO a) -> EitherT ServantErr IO a
latestQ p = liftIO (uncurry (p key) =<< query db (GetLatest key))
versionQ :: (Key -> Version -> Page Text -> IO a) -> Version -> EitherT ServantErr IO a
versionQ p v = liftIO (query db (GetVersion key v))
>>= \case Left e -> handle e
Right x -> liftIO (p key v x)
pp :: Key -> Version -> Page Text -> IO PrettyPage
pp k v p = fmap (PP renders k v) $ for p $ \b ->
case pandocReader renders def (filter (/= '\r') . T.unpack $ b) of
Left err -> return $ writePandocError err
Right pd -> writeHtml (pandocWriterOptions renders) <$> runEndoIO (pandocProcessors renders) pd
rp k v p = return (RP renders k v p)
handle :: DixiError -> EitherT ServantErr IO a
handle e = left err404 { errBody = dixiError (headerBlock renders) e }
server :: AcidState Database -> Renders -> Server Dixi
server db cfg = page db cfg
|: page db cfg "Main_Page"