Handler.hs

module Network.Orchid.Core.Handler (
    hRepository
  , hViewer
  , hWiki
  , hWikiCustomViewer
  ) where

import Control.Monad.State (lift, gets)
import Control.Concurrent.STM

import Network.Salvia.Advanced.ExtendedFileSystem (hExtendedFileSystem)
import Network.Salvia.Handlers.Directory (hDirectory)
import Network.Salvia.Handlers.Error (hError)
import Network.Salvia.Handlers.File (hFileResource)
import Network.Salvia.Handlers.File (hUri)
import Network.Salvia.Handlers.FileSystem (hFileSystem, hFileTypeDispatcher)
import Network.Salvia.Handlers.Login
import Network.Salvia.Handlers.Login (UserDatabase, TUserSession)
import Network.Salvia.Handlers.MethodRouter (hPOST, hMethodRouter)
import Network.Salvia.Handlers.PathRouter (hPrefix, hPath, hPathRouter)
import Network.Salvia.Handlers.Rewrite (hWithoutDir)
import Network.Salvia.Httpd (Handler, request)
import Network.Protocol.Http (Method (..), Status (..))
import Network.Protocol.Uri ((/+), URI(..))
import Misc.Commons ((.$))
import Network.Orchid.Backend.CachingBackend (cachingBackend)
import Network.Orchid.Backend.DarcsBackend (darcsBackend)
import Network.Orchid.Core.Backend (Backend)
import Network.Orchid.Core.Format (extension)
import Network.Orchid.Core.Liaison (hWikiStore, hWikiDelete, hWikiRetrieve)
import Network.Orchid.FormatRegister (wikiFormats)

import Paths_orchid

-------- main entry point -----------------------------------------------------

backend :: FilePath -> Backend
backend dataDir =
    cachingBackend (dataDir /+ "_cache/")
  $ darcsBackend dataDir "_cache/"

hRepository :: Show a => FilePath -> FilePath -> UserDatabase b -> TUserSession a -> Handler ()
hRepository dataDir workDir userdb session =
    hPrefix "/_" 
 .$ hFileSystem (dataDir /+ "_")
  $ hFileTypeDispatcher dataDir
      hDirectory
    $ hWithoutDir dataDir
    $ hWikiREST workDir userdb session
    $ backend dataDir

hViewer :: FilePath -> Handler ()
hViewer dir = do
  hPath "/"
   .$ hFileResource (dir /+ "show.html")
    $ hExtendedFileSystem dir

hWiki :: Show a => FilePath -> FilePath -> TUserDatabase FilePath -> TUserSession a -> Handler ()
hWiki dataDir workDir userdb session = do
  viewerDir <- lift $ getDataFileName "viewer"
  hWikiCustomViewer viewerDir dataDir workDir userdb session

hWikiCustomViewer :: Show a
  => FilePath -> FilePath -> FilePath
  -> TUserDatabase FilePath -> TUserSession a -> Handler ()
hWikiCustomViewer viewerDir dataDir workDir tuserdb session = do
  userdb <- lift . atomically $ readTVar tuserdb
  hPrefix "/data"
   .$ hRepository dataDir workDir userdb session
    $ authHandlers tuserdb session
    $ hViewer viewerDir

authHandlers :: Show a => TUserDatabase FilePath -> TUserSession a -> Handler () -> Handler ()
authHandlers tuserdb session handler = do
  userdb <- lift . atomically $ readTVar tuserdb
  hPathRouter [
      ("/loginfo", hAuthorized userdb "loginfo" (const $ hLoginfo session) session)
    , ("/login",   hPOST $ hLogin userdb session)
    , ("/logout",  hPOST $ hLogout session)
    , ("/signup",  hAuthorized userdb "signup" (const $ hPOST $ hSignup tuserdb ["loginfo", "show", "edit", "create"]) session)
    ] handler

-------- REST interface -------------------------------------------------------

-- The wiki module will act as a REST interface by using the MethodRouter
-- handler to dispatch on the HTTP request method.

hWikiREST :: Show a => FilePath -> UserDatabase b -> TUserSession a -> Backend -> Handler ()
hWikiREST workDir userdb session backend =
  hUri $ \uri ->
    previewHandlers backend workDir uri
  $ actionHandlers  backend workDir uri userdb session
  $ hError BadRequest

actionHandlers :: Show a => Backend -> FilePath -> URI -> UserDatabase b -> TUserSession a -> Handler () -> Handler ()
actionHandlers backend workDir uri userdb session =
  hMethodRouter [
    (GET,    hAuthorized userdb "show"   (const $ hWikiRetrieve backend workDir False uri) session)
  , (PUT,    hAuthorized userdb "edit"   (flip (hWikiStore  backend) uri)                  session)
  , (DELETE, hAuthorized userdb "delete" (flip (hWikiDelete backend) uri)                  session)
  ]

previewHandlers :: Backend -> FilePath -> URI -> Handler () -> Handler ()
previewHandlers backend workDir uri = hPathRouter (
    map (\ext -> ("/preview." ++ ext, hWikiRetrieve backend workDir True uri))
  $ map extension wikiFormats)