Liaison.hs

module Network.Orchid.Core.Liaison (
    hWikiRetrieve
  , hWikiDelete
  , hWikiStore
  ) where

import Control.Applicative ((<$>))
import Control.Monad.State (gets, lift)
import Data.Encoding (encodeLazy)
import Data.Encoding.UTF8 (UTF8 (..))
import Data.List (find)
import qualified Data.ByteString.Lazy as B

import Network.Salvia.Handlers.Error (safeIO, hError, hCustomError)
import Network.Salvia.Handlers.File ()
import Network.Salvia.Handlers.Login (username, User)
import Network.Salvia.Handlers.MethodRouter ()
import Network.Salvia.Handlers.PathRouter ()
import Network.Salvia.Httpd (UriHandler, sendBs, request, modResponse, contentsUtf8)
import Network.Protocol.Http
import Network.Orchid.Core.Backend (Backend (..), Revision (..))
import Network.Orchid.Core.Format (WikiFormat (..), Output (..))
import Network.Orchid.FormatRegister
import qualified Network.Protocol.Uri as U

-- TODO: should history be here instead of format dir?

-------- showing wiki documents -----------------------------------------------

{- |
Dependent on the `b' flag we either bounce the PUTted contents back in the
requested format, or we open the source version of the requested resource and
print this back in the requested format.
-}

hWikiRetrieve :: Backend -> FilePath -> Bool -> UriHandler ()
hWikiRetrieve backend workDir b u = do

  -- Fetch revision identifier from URI query string.
  rev <- Revision "" "" . U.query . uri <$> gets request

  -- Compute the source file and format handler.
  let src = U.relative $ U.setExtension Nothing u
      ext = maybe "txt" id $ U.extension u
      fmt = maybe defaultFormat id $ find ((ext==) . extension) wikiFormats

  -- The body might be retrieved from our backend or from the request itself.
  body <- if b
    then contentsUtf8
    else lift (retrieve backend (U.path src) rev)

  -- Format the body using the selected wiki handler or return an error when
  -- the body could not be retrieved.
  case body of
    Nothing -> hError NotFound
    Just s -> do
      b <- lift $ (handler fmt) backend workDir src s
      (body, enc) <- return $ case b of
        TextOutput   s  -> (encodeLazy UTF8 s, Just utf8)
        BinaryOutput bs -> (bs, Nothing)

      modResponse
        $ setStatus OK
        . setContentType   (mime fmt) enc
        . setContentLength (B.length body)
      sendBs body

-------- deleting wiki documents ----------------------------------------------

-- TODO:generalize deletion/storage

hWikiDelete :: Backend -> Maybe User -> UriHandler ()
hWikiDelete backend user u = do

  -- Fetch revision identifier from URI query string.
  revname <- gets (U.query . uri . request)
  let rev = Revision "" (maybe "guest" username user) revname
  let src = U.setExtension Nothing u

  safeIO
    (delete backend (U.path $ U.relative src) rev)
    (const $ return ())

-------- storing wiki documents -----------------------------------------------

hWikiStore :: Backend -> Maybe User -> UriHandler ()
hWikiStore backend user u = do

  -- Fetch revision identifier from URI query string.
  revname <- gets (U.query . uri . request)
  let rev = Revision "" (maybe "guest" username user) revname

  let src = U.setExtension Nothing u

  -- Check history to prevent duplicate revision name.
  p <- maybe [] (filter (\(Revision d a n) -> n == revname))
    <$> lift (history backend (U.path $ U.relative src))

  case p of
    x:xs -> hCustomError BadRequest "existing revision name"
    []   -> do
      c <- contentsUtf8
      case c of
        Nothing -> modResponse $ setStatus BadRequest
        Just c' -> safeIO
          (store backend (U.path $ U.relative src) rev c')
          (const $ return ())