diff --git a/orchid.cabal b/orchid.cabal --- a/orchid.cabal +++ b/orchid.cabal @@ -1,5 +1,5 @@ Name: orchid -Version: 0.0.6 +Version: 0.0.7 Description: Haskell Wiki Library Synopsis: Haskell Wiki Library Category: Network, Web @@ -10,8 +10,9 @@ Build-Type: Simple Build-Depends: base, bytestring, - salvia == 0.0.4, + salvia == 0.0.5, xml, + extensible-exceptions, containers, QuickCheck, parsec <= 2.1.0.1, @@ -21,6 +22,7 @@ process, unix, nano-md5, + filestore, hscolour, encoding, utf8-string, @@ -43,9 +45,6 @@ Text.Document.PluginRegister, Text.Xhtml.Xhtml, Text.Xml.Xml, - Network.Orchid.Backend.CachingBackend, - Network.Orchid.Backend.DarcsBackend, - Network.Orchid.Core.Backend, Network.Orchid.Core.Format, Network.Orchid.Core.Handler, Network.Orchid.Core.Liaison, diff --git a/src/Network/Orchid/Backend/CachingBackend.hs b/src/Network/Orchid/Backend/CachingBackend.hs deleted file mode 100644 --- a/src/Network/Orchid/Backend/CachingBackend.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Network.Orchid.Backend.CachingBackend (cachingBackend) where - -#if (__GLASGOW_HASKELL__ < 609) -import Control.Exception hiding (IOException) -#else -import Control.Exception -#endif - -import System.Posix.Files -import System.Directory -import qualified System.IO.UTF8 as U - -import Network.Orchid.Core.Backend - -#if (__GLASGOW_HASKELL__ < 609) -type IOException = Exception -#endif - -cachingBackend :: FilePath -> Backend -> Backend -cachingBackend cache backend = Backend { - store = store backend - , delete = delete backend - , retrieve = cachedRetrieve cache backend - , history = history backend - } - --------- backend procedures --------------------------------------------------- - -cachedRetrieve :: FilePath -> Backend -> FilePath -> Revision -> IO (Maybe String) -cachedRetrieve cache backend file rev = do - hit <- (try $ U.readFile $ concat [cache, file, "?", name rev]) :: IO (Either IOException String) - case hit of - -- Cache hit, use this one. - Right doc -> return $ Just doc - -- No cache hit, forward to backend and store in cache dir. - Left e -> do - doc <- retrieve backend file rev --- maybe (return ()) (U.writeFile $ concat [cache, file, "?", name rev]) doc - return doc - diff --git a/src/Network/Orchid/Backend/DarcsBackend.hs b/src/Network/Orchid/Backend/DarcsBackend.hs deleted file mode 100644 --- a/src/Network/Orchid/Backend/DarcsBackend.hs +++ /dev/null @@ -1,165 +0,0 @@ -module Network.Orchid.Backend.DarcsBackend (darcsBackend) where - -import Control.Applicative hiding (empty) -import Text.ParserCombinators.Parsec hiding (many, optional, (<|>), try) -import System.Directory (removeFile) -import System.Process (runInteractiveProcess, waitForProcess, runProcess) -import System.Exit -import qualified System.IO.UTF8 as U - -#if (__GLASGOW_HASKELL__ < 609) -import Control.Exception hiding (IOException) -#else -import Control.Exception -#endif - -import Misc.Commons (splitsWith, eitherToMaybe, trim) -import Network.Protocol.Uri ((/+), normalize) -import Network.Orchid.Core.Backend - -#if (__GLASGOW_HASKELL__ < 609) -type IOException = Exception -#endif - -type DarcsRepository = FilePath - -{- -Create a Darcs wiki backend bound to the specified repository location. The -temp directory specfied will be used to store intermediate results from -patching old revisions. This directory can easily be shared with the cache -directory for the `CachingBackend' module. --} - -darcsBackend :: FilePath -> FilePath -> Backend -darcsBackend repo temp = Backend { - store = darcsStore repo - , delete = darcsDelete repo - , retrieve = darcsRetrieve repo temp - , history = darcsHistory repo - } - --------- store a documents in a new darcs patch ------------------------------- - -darcsStore :: DarcsRepository -> FilePath -> Revision -> String -> IO () -darcsStore repo file cha@(Revision _ author name) doc = do - - -- Write the new document to the source file. - U.writeFile (repo /+ file) doc - - -- Add file to repository. - runProcess "darcs" ["add", "--case-ok", file] - (Just repo) Nothing Nothing Nothing Nothing - >>= waitForProcess - - -- Record the changes for this file. - runProcess "darcs" [ - "record", file - , "--all" - , "--patch-name=" ++ name - , "--author=" ++ author - ] (Just repo) Nothing Nothing Nothing Nothing - >>= waitForProcess - - return () - --------- delete a document from the darcs repo -------------------------------- - -darcsDelete :: DarcsRepository -> FilePath -> Revision -> IO () -darcsDelete repo file cha@(Revision _ author name) = do - - -- Write the new document to the source file. - removeFile (repo /+ file) - - -- Record the changes for this file. - runProcess "darcs" [ - "record", file - , "--all" - , "--patch-name=" ++ name - , "--author=" ++ author - ] (Just repo) Nothing Nothing Nothing Nothing - >>= waitForProcess - - -- TODO: cache removal. - - return () - -------------------------------------------------------------------------------- - -darcsRetrieve :: DarcsRepository -> FilePath -> FilePath -> Revision -> IO (Maybe String) -darcsRetrieve repo temp file rev = - case name rev of - "" -> eitherToMaybe <$> (try (U.readFile (repo /+ file)) :: IO (Either IOException String)) - n -> retrieveDiff file repo temp n - -retrieveDiff :: FilePath -> FilePath -> FilePath -> String -> IO (Maybe String) -retrieveDiff file repo temp name = do - - -- Load the diff from darcs. - (inp, out, err, pid) <- - runInteractiveProcess "darcs" [ - "diff", file - , "--unified" - , "--store-in-memory" - , "--to-patch=^" ++ (escapePatch name) ++ "$" - ] - (Just repo) Nothing - - -- Pipe the diff from darcs straight to patch. - let prev = temp ++ file ++ "?" ++ name - pid' <- runProcess "patch" [ - "--unified" - , "--output=" ++ prev - ] - (Just repo) Nothing - (Just out) Nothing Nothing - - -- Wait for both processes in pipe to terminate. - exit' <- waitForProcess pid' - exit <- waitForProcess pid - - -- Return just the document or nothing on failure. - case exit of - ExitSuccess -> Just <$> U.readFile (repo /+ prev) - -- TODO: just to damn ugly. - ExitFailure _ -> removeFile (repo /+ prev) >> return Nothing - --- Escape special characters in text that will end up in an XML document. -escapePatch :: String -> String -escapePatch [] = [] -escapePatch ('(':xs) = "\\(" ++ escapePatch xs -escapePatch (')':xs) = "\\)" ++ escapePatch xs -escapePatch ('+':xs) = "\\+" ++ escapePatch xs -escapePatch ('.':xs) = "\\." ++ escapePatch xs -escapePatch (x:xs) = x : escapePatch xs - --------- request and parse modification history ------------------------------- - -darcsHistory :: DarcsRepository -> FilePath -> IO (Maybe History) -darcsHistory repo file = do - (inp, out, err, pid) <- - runInteractiveProcess "darcs" ["changes", file] (Just repo) Nothing - s <- pHistory <$> U.hGetContents out - waitForProcess pid - return s - -pHistory :: String -> Maybe History -pHistory h = splitsWith "\n\n" h >>= pRevisions . snd - -pRevisions :: String -> Maybe History -pRevisions his = do - case splitsWith "\n\n" his of - Nothing -> fmap pure $ pRevision his - Just (c, cs) -> do - c' <- pRevision c - cs' <- pRevisions cs - return (c' : cs') - -pRevision :: String -> Maybe Revision -pRevision revision = do - let tmplt = length "Sun Aug 10 19:20:52 CEST 2008" - (inf, body) <- splitsWith "\n" revision - let date = take tmplt inf - author = trim (drop tmplt inf) - name = dropWhile (flip elem " *") $ head $ lines body - return $ Revision date author name - diff --git a/src/Network/Orchid/Core/Backend.hs b/src/Network/Orchid/Core/Backend.hs deleted file mode 100644 --- a/src/Network/Orchid/Core/Backend.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Network.Orchid.Core.Backend where - -import Data.List (intercalate) - -type Author = String -type Date = String - -data Revision = - Revision { - date :: Date - , author :: Author - , name :: String - } - -instance Show Revision where - show (Revision d a n) = intercalate "\n" [sd, sa, sn] - where - sd = if null d then "" else d - sa = if null a then "" else a - sn = if null n then "" else n - -type History = [Revision] - -data Backend = - Backend { - store :: FilePath -> Revision -> String -> IO () - , retrieve :: FilePath -> Revision -> IO (Maybe String) - , delete :: FilePath -> Revision -> IO () - , history :: FilePath -> IO (Maybe History) - } - diff --git a/src/Network/Orchid/Core/Format.hs b/src/Network/Orchid/Core/Format.hs --- a/src/Network/Orchid/Core/Format.hs +++ b/src/Network/Orchid/Core/Format.hs @@ -1,9 +1,8 @@ module Network.Orchid.Core.Format where import Data.ByteString.Lazy (ByteString) - +import Data.FileStore (FileStore) import Network.Protocol.Uri (URI) -import Network.Orchid.Core.Backend -- Formats produce proper UTF-8 text or binary docs. (TODO: ascii for tex?) data Output = @@ -13,8 +12,12 @@ -- Wiki format description data type. data WikiFormat = WikiFormat { - extension :: String - , mime :: String - , handler :: Backend -> FilePath -> URI -> String -> IO Output + postfix :: String + , mime :: String + , handler :: FileStore + -> FilePath -- Working dir. + -> FilePath -- Document name. + -> String -- Contents. + -> IO Output } diff --git a/src/Network/Orchid/Core/Handler.hs b/src/Network/Orchid/Core/Handler.hs --- a/src/Network/Orchid/Core/Handler.hs +++ b/src/Network/Orchid/Core/Handler.hs @@ -1,74 +1,72 @@ module Network.Orchid.Core.Handler ( - hRepository + FileStoreType (..) + , hRepository , hViewer , hWiki , hWikiCustomViewer ) where -import Control.Monad.State (lift, gets) 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) +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.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/" +data FileStoreType = Git | Darcs -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 +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 => FilePath -> FilePath -> TUserDatabase FilePath -> TUserSession a -> Handler () -hWiki dataDir workDir userdb session = do +hWiki :: Show a => FileStoreType -> FilePath -> FilePath -> TUserDatabase FilePath -> TUserSession a -> Handler () +hWiki kind repo workDir userdb session = do viewerDir <- lift $ getDataFileName "viewer" - hWikiCustomViewer viewerDir dataDir workDir userdb session + hWikiCustomViewer viewerDir kind repo workDir userdb session hWikiCustomViewer :: Show a - => FilePath -> FilePath -> FilePath + => FilePath -> FileStoreType -> FilePath -> FilePath -> TUserDatabase FilePath -> TUserSession a -> Handler () -hWikiCustomViewer viewerDir dataDir workDir tuserdb session = do +hWikiCustomViewer viewerDir kind repo workDir tuserdb session = do userdb <- lift . atomically $ readTVar tuserdb hPrefix "/data" - .$ hRepository dataDir workDir userdb session - $ authHandlers tuserdb session - $ hViewer viewerDir + (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 @@ -85,23 +83,23 @@ -- 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 = +hWikiREST :: Show a => FilePath -> UserDatabase b -> TUserSession a -> FileStore -> Handler () +hWikiREST workDir userdb session filestore = hUri $ \uri -> - previewHandlers backend workDir uri - $ actionHandlers backend workDir uri userdb session - $ hError BadRequest + previewHandlers filestore workDir uri + $ actionHandlers filestore workDir uri userdb session + $ hError BadRequest -actionHandlers :: Show a => Backend -> FilePath -> URI -> UserDatabase b -> TUserSession a -> Handler () -> Handler () -actionHandlers backend workDir uri userdb session = +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 backend workDir False uri) session) - , (PUT, hAuthorized userdb "edit" (flip (hWikiStore backend) uri) session) - , (DELETE, hAuthorized userdb "delete" (flip (hWikiDelete backend) uri) session) + (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 :: Backend -> FilePath -> URI -> Handler () -> Handler () -previewHandlers backend workDir uri = hPathRouter ( - map (\ext -> ("/preview." ++ ext, hWikiRetrieve backend workDir True uri)) - $ map extension wikiFormats) +previewHandlers :: FileStore -> FilePath -> URI -> Handler () -> Handler () +previewHandlers filestore workDir uri = hPathRouter ( + map (\ext -> ("/preview." ++ ext, hWikiRetrieve filestore workDir True uri)) + $ map postfix wikiFormats) diff --git a/src/Network/Orchid/Core/Liaison.hs b/src/Network/Orchid/Core/Liaison.hs --- a/src/Network/Orchid/Core/Liaison.hs +++ b/src/Network/Orchid/Core/Liaison.hs @@ -1,29 +1,30 @@ module Network.Orchid.Core.Liaison ( hWikiRetrieve - , hWikiDelete + , hWikiDeleteOrRename , hWikiStore + , hWikiSearch ) where import Control.Applicative ((<$>)) +import Control.Exception.Extensible (try) 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 Data.FileStore hiding (NotFound) +import Data.List (find, intercalate) +import Data.Record.Label +import Network.Orchid.Core.Format (WikiFormat (..), Output (..)) +import Network.Orchid.FormatRegister +import Network.Protocol.Http +import Network.Protocol.Uri import Network.Salvia.Handlers.Error (safeIO, hError, hCustomError) import Network.Salvia.Handlers.File () -import Network.Salvia.Handlers.Login (username, User) +import Network.Salvia.Handlers.Login (User, username, email) 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? +import Network.Salvia.Httpd (Handler, UriHandler, sendBs, sendStr, request, response, contentsUtf8, uriEncodedPostParamsUTF8) +import Misc.Commons (safeRead) +import qualified Data.ByteString.Lazy as B -------- showing wiki documents ----------------------------------------------- @@ -33,76 +34,115 @@ print this back in the requested format. -} -hWikiRetrieve :: Backend -> FilePath -> Bool -> UriHandler () -hWikiRetrieve backend workDir b u = do +hWikiRetrieve :: FileStore -> FilePath -> Bool -> UriHandler () +hWikiRetrieve filestore workDir b u = do - -- Fetch revision identifier from URI query string. - rev <- Revision "" "" . U.query . uri <$> gets request + -- Fetch revision identifier from URI query string and convert this to a + -- Maybe based on string-emptyness. + let rev = lget query u + revId = if null rev then Nothing else Just rev -- 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 + let src = mkPathRelative $ lset extension Nothing $ lget path u + ext = maybe "txt" id $ lget (extension % path) u + fmt = maybe defaultFormat id $ find ((ext==) . postfix) wikiFormats - -- The body might be retrieved from our backend or from the request itself. + -- The body might be retrieved from our filestore or from the request itself. body <- if b then contentsUtf8 - else lift (retrieve backend (U.path src) rev) + else lift ( + either (\e -> const Nothing (e::FileStoreError)) Just + <$> try (smartRetrieve filestore False src revId)) -- 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 + b <- lift $ (handler fmt) filestore 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) + enterM response $ do + setM status OK + setM contentType (mime fmt, enc) + setM contentLength (Just $ fromIntegral $ B.length body) sendBs body -------- deleting wiki documents ---------------------------------------------- -- TODO:generalize deletion/storage -hWikiDelete :: Backend -> Maybe User -> UriHandler () -hWikiDelete backend user u = do +hWikiDeleteOrRename :: FileStore -> User -> UriHandler () +hWikiDeleteOrRename filestore 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 + let rev = lget query u - safeIO - (delete backend (U.path $ U.relative src) rev) - (const $ return ()) + if null rev + then hCustomError BadRequest errEmptyRev + else do + mdoc <- contentsUtf8 + let aut = Author (username user) (email user) + src = mkPathRelative $ lset extension Nothing $ lget path u + lift $ case mdoc of + Nothing -> delete filestore src aut rev + Just mv -> rename filestore src mv aut rev +errEmptyRev, errEmptyRes :: String +errEmptyRev = "empty revision name not allowed" +errEmptyRes = "empty resource name not allowed" + -------- storing wiki documents ----------------------------------------------- -hWikiStore :: Backend -> Maybe User -> UriHandler () -hWikiStore backend user u = do +hWikiStore :: FileStore -> User -> UriHandler () +hWikiStore filestore 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 rev = lget query u + mdoc <- contentsUtf8 + case (null rev, mdoc) of - let src = U.setExtension Nothing u + -- Error cases. + (True, Nothing) -> hCustomError BadRequest (errEmptyRev ++ "\n" ++ errEmptyRes) + (True, Just _) -> hCustomError BadRequest errEmptyRev + (False, Nothing) -> hCustomError BadRequest errEmptyRes - -- Check history to prevent duplicate revision name. - p <- maybe [] (filter (\(Revision d a n) -> n == revname)) - <$> lift (history backend (U.path $ U.relative src)) + (False, Just doc) -> lift $ do + let aut = Author (username user) (email user) + src = mkPathRelative $ lset extension Nothing $ lget path u + save filestore src aut rev doc - 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 ()) +-------- searching wiki documents --------------------------------------------- + +hWikiSearch :: FileStore -> Handler () +hWikiSearch filestore = do + + params <- uriEncodedPostParamsUTF8 + + case getSearchInfo params of + Nothing -> hCustomError BadRequest "no search query specified" + Just (a, b, c, d) -> do + res <- lift $ search filestore (SearchQuery [a] b c d) + enterM response $ do + setM status OK + setM contentType ("text/plain", Just utf8) + sendStr (intercalate "\n\n" $ map showMatch res) + +getSearchInfo :: Maybe Parameters -> Maybe (String, Bool, Bool, Bool) +getSearchInfo params = do + p <- params + patterns <- "patterns" `lookup` p >>= id + wholewords <- "wholewords" `lookup` p >>= id >>= safeRead + matchall <- "matchall" `lookup` p >>= id >>= safeRead + ignorecase <- "ignorecase" `lookup` p >>= id >>= safeRead + return (patterns, wholewords, matchall, ignorecase) + +showMatch :: SearchMatch -> String +showMatch match = + intercalate "\n" + $ map (\(a, b) -> a ++ "=" ++ b match) [ + ("resource", matchResourceName) + , ("linenumber", show . matchLineNumber) + , ("line", matchLine) + ] diff --git a/src/Network/Orchid/Format/Haskell.hs b/src/Network/Orchid/Format/Haskell.hs --- a/src/Network/Orchid/Format/Haskell.hs +++ b/src/Network/Orchid/Format/Haskell.hs @@ -1,14 +1,14 @@ module Network.Orchid.Format.Haskell (fHaskell) where -import Text.Document.Document -import Network.Orchid.Core.Backend +import Data.FileStore (FileStore) import Network.Orchid.Core.Format import Network.Protocol.Uri +import Text.Document.Document fHaskell = WikiFormat "hs" "text/plain" haskell -haskell :: Backend -> FilePath -> URI -> String -> IO Output -haskell backend _ _ src = return +haskell :: FileStore -> FilePath -> FilePath -> String -> IO Output +haskell _ _ _ src = return $ TextOutput $ either show show $ fromWiki src diff --git a/src/Network/Orchid/Format/History.hs b/src/Network/Orchid/Format/History.hs --- a/src/Network/Orchid/Format/History.hs +++ b/src/Network/Orchid/Format/History.hs @@ -1,19 +1,38 @@ module Network.Orchid.Format.History (fHistory) where import Control.Monad (liftM) +import Data.FileStore (FileStore (history), Author (..), TimeRange (..), Revision (..)) import Data.List (intercalate) +import Data.Record.Label (lget) +import Network.Orchid.Core.Format (Output (..), WikiFormat (..)) +import Network.Protocol.Uri (URI, path, mkPathRelative) +import Text.Document.Document () -import Text.Document.Document -import Network.Orchid.Core.Backend -import Network.Orchid.Core.Format -import qualified Network.Protocol.Uri as U +fHistory :: WikiFormat +fHistory = WikiFormat "his" "text/plain" his -fHistory = WikiFormat "his" "text/plain" history' +his :: FileStore -> FilePath -> FilePath -> String -> IO Output +his filestore _ p _ = do -history' :: Backend -> FilePath -> U.URI -> String -> IO Output -history' backend _ f _ = do - liftM - (TextOutput . maybe "no history" (intercalate "\n\n" . map show)) - (history backend $ U.path $ U.relative f) + -- Get all the history for one single document. + revs <- history filestore [mkPathRelative p] noTimeRange + return + $ TextOutput + $ intercalate "\n\n" + $ map showRevision + revs +noTimeRange :: TimeRange +noTimeRange = TimeRange Nothing Nothing + +showRevision :: Revision -> String +showRevision rev = + intercalate "\n" + $ map (\(a, b) -> a ++ "=" ++ b rev) [ + ("date", show . revDateTime) + , ("author", authorName . revAuthor) + , ("email", authorEmail . revAuthor) + , ("description", revDescription) + , ("id", revId) + ] diff --git a/src/Network/Orchid/Format/Html.hs b/src/Network/Orchid/Format/Html.hs --- a/src/Network/Orchid/Format/Html.hs +++ b/src/Network/Orchid/Format/Html.hs @@ -2,14 +2,15 @@ import Control.Monad (liftM) -import Text.Document.Document -import Network.Orchid.Core.Backend +import Data.FileStore (FileStore) import Network.Orchid.Core.Format import Network.Protocol.Uri +import Text.Document.Document +fHtml :: WikiFormat fHtml = WikiFormat "html" "text/html" html -html :: Backend -> FilePath -> URI -> String -> IO Output +html :: FileStore -> FilePath -> FilePath -> String -> IO Output html _ work _ src = do case fromWiki src of Left err -> return $ TextOutput (show err) diff --git a/src/Network/Orchid/Format/Latex.hs b/src/Network/Orchid/Format/Latex.hs --- a/src/Network/Orchid/Format/Latex.hs +++ b/src/Network/Orchid/Format/Latex.hs @@ -1,13 +1,14 @@ module Network.Orchid.Format.Latex (fLatex) where -import Text.Document.Document -import Network.Orchid.Core.Backend +import Data.FileStore (FileStore) import Network.Orchid.Core.Format import Network.Protocol.Uri +import Text.Document.Document +fLatex :: WikiFormat fLatex = WikiFormat "tex" "text/plain" latex -latex :: Backend -> FilePath -> URI -> String -> IO Output +latex :: FileStore -> FilePath -> FilePath -> String -> IO Output latex _ _ _ src = return $ TextOutput $ either show toLaTeX diff --git a/src/Network/Orchid/Format/Pdf.hs b/src/Network/Orchid/Format/Pdf.hs --- a/src/Network/Orchid/Format/Pdf.hs +++ b/src/Network/Orchid/Format/Pdf.hs @@ -2,18 +2,18 @@ import Control.Monad (liftM) import Data.ByteString.Lazy hiding (writeFile) +import Data.FileStore (FileStore) +import Network.Orchid.Core.Format +import Network.Protocol.Uri import Prelude hiding (readFile) import System.Process (waitForProcess, runProcess) - import Text.Document.Document -import Network.Protocol.Uri -import Network.Orchid.Core.Backend -import Network.Orchid.Core.Format +fPdf :: WikiFormat fPdf = WikiFormat "pdf" "application/pdf" pdf -- TODO: write to _cache dir, not /tmp -pdf :: Backend -> FilePath -> URI -> String -> IO Output +pdf :: FileStore -> FilePath -> FilePath -> String -> IO Output pdf _ _ _ src = do writeFile "/tmp/tex-to-pdf.tex" $ either show toLaTeX diff --git a/src/Network/Orchid/Format/Plain.hs b/src/Network/Orchid/Format/Plain.hs --- a/src/Network/Orchid/Format/Plain.hs +++ b/src/Network/Orchid/Format/Plain.hs @@ -1,12 +1,13 @@ module Network.Orchid.Format.Plain (fPlain) where -import Text.Document.Document -import Network.Orchid.Core.Backend +import Data.FileStore (FileStore) import Network.Orchid.Core.Format import Network.Protocol.Uri +import Text.Document.Document +fPlain :: WikiFormat fPlain = WikiFormat "txt" "text/plain" plain -plain :: Backend -> FilePath -> URI -> String -> IO Output +plain :: FileStore -> FilePath -> FilePath -> String -> IO Output plain _ _ _ = return . TextOutput diff --git a/src/Network/Orchid/Format/Xml.hs b/src/Network/Orchid/Format/Xml.hs --- a/src/Network/Orchid/Format/Xml.hs +++ b/src/Network/Orchid/Format/Xml.hs @@ -2,14 +2,15 @@ import Text.XML.Light.Output -import Text.Document.Document -import Network.Orchid.Core.Backend +import Data.FileStore (FileStore) import Network.Orchid.Core.Format import Network.Protocol.Uri +import Text.Document.Document +fXml :: WikiFormat fXml = WikiFormat "xml" "text/xml" xml -xml :: Backend -> FilePath -> URI -> String -> IO Output +xml :: FileStore -> FilePath -> FilePath -> String -> IO Output xml _ _ _ src = return $ TextOutput $ either show (ppContent . toXML) diff --git a/src/Network/Orchid/Wiki.hs b/src/Network/Orchid/Wiki.hs --- a/src/Network/Orchid/Wiki.hs +++ b/src/Network/Orchid/Wiki.hs @@ -1,5 +1,6 @@ module Network.Orchid.Wiki ( - hRepository + FileStoreType (..) + , hRepository , hViewer , hWiki ) where diff --git a/src/Text/Document/Core/Type.hs b/src/Text/Document/Core/Type.hs --- a/src/Text/Document/Core/Type.hs +++ b/src/Text/Document/Core/Type.hs @@ -394,7 +394,7 @@ _contentsIxml :: (XL.Content) -- "src/Text/Document/Printer/Xhtml.ag"(line 89, column 16) _lhsOxhtml = - nameDiv name_ _contentsIxhtml + nameAnchor name_ _contentsIxhtml -- "src/Text/Document/Printer/Xml.ag"(line 87, column 16) _lhsOxml = xmlElem "anchor" [xmlText name_, _contentsIxml] diff --git a/src/Text/Document/Plugin/Formula.hs b/src/Text/Document/Plugin/Formula.hs --- a/src/Text/Document/Plugin/Formula.hs +++ b/src/Text/Document/Plugin/Formula.hs @@ -1,35 +1,24 @@ module Text.Document.Plugin.Formula (formulaPlugin) where import Control.Applicative - -#if (__GLASGOW_HASKELL__ < 609) -import Control.Exception hiding (IOException) -#else -import Control.Exception -#endif - +import Control.Exception.Extensible import Control.Monad (when) +import Data.ByteString (pack) import Data.Char (ord) import Data.Digest.OpenSSL.MD5 (md5sum) -import Data.ByteString (pack) import Data.List (intercalate) +import Misc.Commons (trim) +import Network.Protocol.Uri ((/+)) import System.IO import System.IO.Unsafe import System.Posix.Files (getFileStatus, isRegularFile) import System.Process (runInteractiveProcess, waitForProcess, runProcess) -import Text.ParserCombinators.Parsec hiding (many, optional, (<|>), try) - -import Network.Protocol.Uri ((/+)) -import Text.Document.Parser.WikiHelper import Text.Document.Core.Type +import Text.Document.Parser.WikiHelper import Text.Document.Plugin -import Misc.Commons (trim) +import Text.ParserCombinators.Parsec hiding (many, optional, (<|>), try) import qualified Text.Xhtml.Xhtml as H import qualified Text.Xml.Xml as X - -#if (__GLASGOW_HASKELL__ < 609) -type IOException = Exception -#endif -------- hscolour plugin ------------------------------------------------------ diff --git a/src/Text/Xhtml/Xhtml.hs b/src/Text/Xhtml/Xhtml.hs --- a/src/Text/Xhtml/Xhtml.hs +++ b/src/Text/Xhtml/Xhtml.hs @@ -62,6 +62,7 @@ withName n e = attribute "name" n . e -nameDiv = flip withName div -nameSpan = flip withName span +nameAnchor = flip withName (element "a") +nameDiv = flip withName div +nameSpan = flip withName span diff --git a/viewer/js/app.js b/viewer/js/app.js --- a/viewer/js/app.js +++ b/viewer/js/app.js @@ -6,6 +6,7 @@ setupLoadingIcon() installCollapsers() installOptions() + installEnters() installSmartFields() installHandlers() index() @@ -59,7 +60,11 @@ $('#create-account-btn').click(signup) $('#save-btn').click(save) $('#preview-btn').click(preview) + $('#rename-btn').click(rename) $('#delete-btn').click(_delete) + $('#search-btn').click(search) + $('#search-prev-btn').click(searchPrev) + $('#search-next-btn').click(searchNext) } /* ------------------------------------------------------------------------- */ @@ -71,6 +76,7 @@ // Static information. prefix : 'data/' , previewURI : 'data/preview' + , searchURI : 'data/search' , loginURI : 'login' , logoutURI : 'logout' , loginfoURI : 'loginfo' @@ -90,6 +96,12 @@ , author : '' , user : '' + + , search : { + results : [] + , max : 20 + , index : 0 + } } function parseURI () @@ -133,13 +145,13 @@ t = 1000 } - if (Wiki.anchor) - setTimeout( - function () - { + // if (Wiki.anchor) + // setTimeout( + // function () + // { followAnchor(Wiki.anchor) - }, t - ) + // }, t + // ) } function makeURI (prefix, title, ext, rev, anchor) @@ -199,6 +211,7 @@ { viewerHTML(res) $('#history-btn').removeClass('disabled') + panelClose($('#edit-btn'), $('#editor')) processLinks() processImages() setExternalLinks() @@ -247,28 +260,29 @@ function followAnchor (ref) { - var target = $('*[name=' + ref + ']')[0] + var target = $('a[name=' + ref + ']')[0] target.scrollIntoView() - setTimeout( - function () - { - focusElement(target) - }, 0) + // setTimeout( + // function () + // { + // focusElement(target.childeNodes[0]) + // }, 0) } -function focusElement (target) -{ - var div = document.createElement('div') - document.body.appendChild(div) - var bcr = target.getBoundingClientRect() - div.style.left = bcr.left - div.style.top = bcr.top - div.style.width = target.clientWidth - div.style.height = target.clientHeight - $(div).addClass('find') - $(div).fadeOut('slow') -} +// function focusElement (target) +// { + // alert(target) + // var div = document.createElement('div') + // document.body.appendChild(div) + // var bcr = target.getBoundingClientRect() + // div.style.left = bcr.left + // div.style.top = bcr.top + // div.style.width = target.clientWidth + // div.style.height = target.clientHeight + // $(div).addClass('find') + // $(div).fadeOut('slow') +// } /* ---- authentication bar ------------------------------------------------- */ @@ -347,6 +361,7 @@ Wiki.signupURI , { username : $('#su-username').val() , password : $('#su-password').val() + , email : $('#su-email').val() } , function () { @@ -374,7 +389,16 @@ $.get(makeURIExt('his'), '', function (res) { - $('#history').html(historyTable(res)) + $('#history-results').html(historyTable(res)) + $('#history-status').removeClass('error') + $('#history-status').html('') + }, + '', + function (e) + { + $('#history-results').html('') + $('#history-status').addClass('error') + $('#history-status').html('no history available: ' + e.responseText + '') } ) } @@ -383,10 +407,11 @@ { function row (c, i) { - var lines = c.split('\n') - , modified = lines.shift() - , author = lines.shift() - , name = lines.shift() + var modified = c.match( /(^|[\n])date=([^\n]*)/ )[2] + var author = c.match( /(^|[\n])author=([^\n]*)/ )[2] + var email = c.match( /(^|[\n])email=([^\n]*)/ )[2] + var description = c.match( /(^|[\n])description=([^\n]*)/ )[2] + var revid = c.match( /(^|[\n])id=([^\n]*)/ )[2] // Side note. var klass = @@ -398,13 +423,14 @@ , '' , '$modified' , '$author' - , '$name' + , '$description' , '' ].join('').interpolate({ - 'klass' : klass - , 'modified' : modified - , 'author' : author - , 'name' : name + 'uri' : makeURI(Wiki.viewerURI, undefined, undefined, description) + , 'klass' : klass + , 'modified' : modified + , 'author' : author + , 'description' : description }) } @@ -485,6 +511,20 @@ ) } +function rename () +{ + $._delete( + makeURI(undefined, undefined, '', $('#change.full').val()) + , $('#rename').val() + , function (res) + { + $('#edit-status').removeClass('error') + $('#edit-status').html('rename successful') + document.location.hash = $('#rename').val() + } + ) +} + function _delete () { $._delete( @@ -494,8 +534,139 @@ { $('#edit-status').removeClass('error') $('#edit-status').html('delete successful') - // todo: close edit & history. + document.location.hash = '' } ) +} + +/* ---- search bar --------------------------------------------------------- */ + +function search () +{ + if ($('#search-btn').hasClass('disabled')) + return; + + $('#search-status').removeClass('error') + $('#search-status').html('searching...') + + $.post( + Wiki.searchURI + , { patterns : $('#search-terms').val() + , wholewords : 'False' + , matchall : 'False' + , ignorecase : $('#search-case:checked').length == 0 ? 'True' : 'False' + } + , function (res) + { + var rs = Wiki.search.results = res.asHTML().split("\n\n") + Wiki.search.index = 0 + + if (!rs || rs.length == 0 || (rs.length == 1 && !rs[0])) { + $('#search-status').addClass('error') + $('#search-status').html('no search results') + searchPrevReset() + searchNextReset() + $('#search-results').html('') + } else { + $('#search-status').removeClass('error') + $('#search-status').html('search successful (' + rs.length + ' results)') + $('#search-results').html(searchTable()) + } + } + , '' + , function (e) + { + $('#search-status').addClass('error') + $('#search-status').html('search failed: ' + e.responseText + '') + } + ) + +} + +function searchPrevReset () +{ + $('#search-prev-btn').addClass('disabled') + $('#search-prev-btn').html('previous results') +} + +function searchNextReset () +{ + $('#search-next-btn').addClass('disabled') + $('#search-next-btn').html('next results') +} + +function searchNext () +{ + if ($('#search-next-btn').hasClass('disabled')) + return; + + Wiki.search.index += Wiki.search.max + $('#search-results').html(searchTable()) +} + +function searchPrev () +{ + if ($('#search-prev-btn').hasClass('disabled')) + return; + + Wiki.search.index -= Wiki.search.max + $('#search-results').html(searchTable()) +} + +function searchTable () +{ + function row (c, i) + { + var resource = c.match( /(^|[\n])resource=([^\n]*)/ )[2] + var linenumber = c.match( /(^|[\n])linenumber=([^\n]*)/ )[2] + var line = c.match( /(^|[\n])line=([^\n]*)/ )[2] + + return [ + '' + , '$resource' + , '$linenumber' + , '$line' + , '' + ].join('').interpolate({ + 'uri' : makeURI(Wiki.viewerURI, resource, undefined, '') + , 'resource' : resource + , 'linenumber' : linenumber + , 'line' : line + }) + } + + function col (c) + { + return '' + c + '' + } + + var rs = Wiki.search.results + ix = Wiki.search.index + max = Wiki.search.max + prevIx = Math.max(0, ix - max) + prevMax = Math.max(0, ix) + nextIx = Math.min(rs.length - 1, ix + max) + nextMax = Math.min(rs.length - 1, ix + max + max) + + if (prevMax > 0) { + $('#search-prev-btn').removeClass('disabled') + $('#search-prev-btn').html('previous results (' + prevIx + '-' + prevMax + ')') + } else + searchPrevReset() + + if (nextIx < rs.length - 1) { + $('#search-next-btn').removeClass('disabled') + $('#search-next-btn').html('next results (' + nextIx + '-' + nextMax + ')') + } else + searchNextReset() + + return '' + + '' + + '' + + '' + + '' + + '' + + rs.slice(ix, ix + max).map(row).join('') + + '
resourcelinematch
' } diff --git a/viewer/js/ui.js b/viewer/js/ui.js --- a/viewer/js/ui.js +++ b/viewer/js/ui.js @@ -58,6 +58,18 @@ /* ------------------------------------------------------------------------- */ +function installEnters () +{ + $('input[enter]').keyup( + function(e) { + if(e.keyCode == 13) + window[$(this).attr('enter')]() + } + ) +} + +/* ------------------------------------------------------------------------- */ + function installSmartFields () { $('input') @@ -115,7 +127,8 @@ function (a) { var elem = $(others[a]) - return elem.attr('target').match(targets[t]) + return elem.attr('target') + && elem.attr('target').match(targets[t]) && !elem.hasClass('full') } ) diff --git a/viewer/show.html b/viewer/show.html --- a/viewer/show.html +++ b/viewer/show.html @@ -45,18 +45,19 @@
- - + +
login logout
 
@@ -64,8 +65,9 @@
- - + + +
create account
 
@@ -86,17 +88,32 @@
-
+
+
 
+
+
- + + save preview delete + rename
 
+
+ + + diff --git a/viewer/style/plugins.css b/viewer/style/plugins.css --- a/viewer/style/plugins.css +++ b/viewer/style/plugins.css @@ -8,39 +8,15 @@ margin-bottom : 1em; } -.varop, -.keyglyph { - color : #960; -} - -.definition { - color : #005; - font-weight : bold; -} - -.varid { - color : #444; -} - -.keyword { - font-weight : bold; -} - -.comment { - color : #44f; -} - -.conid { - color : #000; -} - -.num { - color : #00a; -} - -.str { - color : #a00; -} +.varop { color : #960; font-weight : normal; } +.keyglyph { color : #960; font-weight : normal; } +.definition { color : #005; font-weight : bold; } +.varid { color : #444; font-weight : normal; } +.keyword { color : #000; font-weight : bold; } +.comment { color : #44f; font-weight : normal; } +.conid { color : #000; font-weight : normal; } +.num { color : #00a; font-weight : normal; } +.str { color : #a00; font-weight : normal; } /* ---- latex formula ------------------------------------------------------ */ diff --git a/viewer/style/ui.ccss b/viewer/style/ui.ccss --- a/viewer/style/ui.ccss +++ b/viewer/style/ui.ccss @@ -28,13 +28,53 @@ border : solid 8px #a47 position : fixed -#format, #auth, #signup, #history, #editor: +#format, #auth, #signup, #history, #editor, #search: display : none #ui: + table: + width : 100% + font-size : 0.7em + line-height : 1.3em + + td, th: + padding : 0.4em + padding-left : 2em + vertical-align : top + font-size : 1.1em + + .current td: + background : #fff + + td: + background : #eee + text-align : left + border-top : solid 1px #ccc + & + td: + background : #eee url('../img/shadow24.png') repeat-y (-40px) 0 + padding-left : 2em + + th: + background : #ddd + text-align : left + border-bottom : solid 1px #bbb + + #author: + width : 200px + + #modified: + width : 220px + + a: + color : #b47 + text-decoration : none + cursor : pointer + &:hover: + color : #305 + a: - margin-right : 0.6em + margin-right : 0.8em margin-bottom : 0.4em padding : 0.4em @@ -44,6 +84,9 @@ cursor : pointer + span: + font-size : 0.7em + &:hover: color : $linkHover @@ -77,6 +120,8 @@ input: background : #fff url('../img/shadow02.png') repeat-x 0 -20px padding : 0.2em + margin-right : 1em + width : 18em border : none color : #555 font-> @@ -90,6 +135,9 @@ color : #a47 font-style : normal + &.checkbox: + color : red + textarea: background : #bbb url('../img/shadow24.png') repeat-y (-30px) 0 width : 100% @@ -115,52 +163,27 @@ font-size : 0.8em font-weight : normal + br: + margin-bottom : 1.2em + +// ---- specific UI components ------------------------------------------------ + #history: background : #ccc - padding : 1em border-bottom : solid 2px #fff display : none - table: - width : 100% - padding : 0.5em - font-size : 0.7em - line-height : 1.3em - - td, th: - padding : 0.4em - padding-left : 2em - vertical-align : top - font-size : 1.1em - - .current td: - background : #fff - - td: - background : #eee - text-align : left - border-top : solid 1px #ccc - & + td: - background : #eee url('../img/shadow24.png') repeat-y (-40px) 0 - padding-left : 2em - - th: - background : #ddd - text-align : left - border-bottom : solid 1px #bbb - #author: width : 200px #modified: width : 220px - a: - color : #b47 - text-decoration : none - cursor : pointer - &:hover: - color : #305 + .status: + display : block + float : none + text-align : right + margin-top : 0 #info: font-size : 0.8em @@ -176,8 +199,6 @@ font-weight : normal #auth: - input: - width : 14em #user-ui: display : none #username: @@ -185,13 +206,11 @@ margin-right : 1em #signup: - input: - width : 14em #su-username: &, #su-password: margin-right : 1em - #editor #change: + #editor #change, #editor #rename: margin-bottom : 1em width : 100% display : block @@ -205,6 +224,21 @@ margin-> left : 0.4em right : 0 + + #search: + #search-terms: + width : 80% + + table: + margin-top : 1.6em + + #resource: + width : 280px + + #linenumber: + width : 40px + +// ---- additional UI elements ------------------------------------------------ #full-btn: margin->