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.Handler.ExtendedFileSystem (hExtendedFileSystem) import Network.Salvia.Handler.Directory (hDirectory, hDirectoryResource) import Network.Salvia.Handler.Error (hError) import Network.Salvia.Handler.File (hFileResource) import Network.Salvia.Handler.File (hUri) import Network.Salvia.Handler.FileSystem (hFileSystem, hFileTypeDispatcher) import Network.Salvia.Handler.Login import Network.Salvia.Handler.MethodRouter (hPOST, hMethodRouter) import Network.Salvia.Handler.PathRouter (hPrefix, hPath, hPathRouter) import Network.Salvia.Handler.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" (\_ -> const () `fmap` (hPOST $ hWikiSearch fs)) session) $ hPrefix "/_" (hFileSystem (repo /+ "_")) $ hFileTypeDispatcher hDirectoryResource ( const $ hWithoutDir repo $ hWikiREST workDir userdb session fs) repo 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) >> return ()) , ("/login", (hPOST $ hLogin userdb session) >> return ()) , ("/logout", (hPOST $ hLogout session) >> return ()) , ("/signup", hAuthorized userdb "signup" (const (hPOST (hSignup tuserdb ["loginfo", "show", "edit", "create"]) >> return ())) 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)