Handler.hs

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

import Control.Concurrent.STM
import Control.Monad.State (lift, gets)
import Data.Record.Label
import Misc.Commons ((.$))
import Data.FileStore (FileStore (..), darcsFileStore, gitFileStore)
import Network.Orchid.Core.Format (postfix)
import Network.Orchid.Core.Liaison (hWikiStore, hWikiDeleteOrRename, hWikiRetrieve, hWikiSearch)
import Network.Orchid.FormatRegister (wikiFormats)
import Network.Protocol.Http (Method (..), Status (..), uri)
import Network.Protocol.Uri ((/+), URI(..), path)
import Network.Salvia.Advanced.ExtendedFileSystem (hExtendedFileSystem)
import Network.Salvia.Handlers.Directory (hDirectory, hDirectoryResource)
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.MethodRouter (hPOST, hMethodRouter)
import Network.Salvia.Handlers.PathRouter (hPrefix, hPath, hPathRouter)
import Network.Salvia.Handlers.Rewrite (hWithoutDir)
import Network.Salvia.Httpd (Handler, request)
import Paths_orchid

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

data FileStoreType = Git | Darcs

mkFileStore :: FileStoreType -> FilePath -> FileStore
mkFileStore Git   = gitFileStore
mkFileStore Darcs = darcsFileStore

-- todo: clean up this mess:
hRepository :: Show a => FileStoreType -> FilePath -> FilePath -> UserDatabase b -> TUserSession a -> Handler ()
hRepository kind repo workDir userdb session =
  let fs = mkFileStore kind repo in
    hPath "/search" (hAuthorized userdb "search" (\_ -> hPOST $ hWikiSearch fs) session)
  $ hPrefix "/_" (hFileSystem (repo /+ "_"))
  $ hFileTypeDispatcher repo hDirectoryResource
  $ const
  $ hWithoutDir repo
  $ hWikiREST workDir userdb session fs

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

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

hWikiCustomViewer :: Show a
  => FilePath -> FileStoreType -> FilePath -> FilePath
  -> TUserDatabase FilePath -> TUserSession a -> Handler ()
hWikiCustomViewer viewerDir kind repo workDir tuserdb session = do
  userdb <- lift . atomically $ readTVar tuserdb
  hPrefix "/data"
    (hRepository kind repo 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 -> FileStore -> Handler ()
hWikiREST workDir userdb session filestore =
  hUri $ \uri ->
  previewHandlers filestore workDir uri
    $ actionHandlers  filestore workDir uri userdb session
    $ hError BadRequest

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

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