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)