{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE PolyKinds         #-}
{-# LANGUAGE TypeFamilies      #-}
{-# LANGUAGE TypeOperators     #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE ViewPatterns      #-}
{-# LANGUAGE ConstraintKinds   #-}

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  () -- imported for orphans
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"