diff --git a/config/models b/config/models index 5b62fc9..b0dec4e 100644 --- a/config/models +++ b/config/models @@ -103,6 +103,7 @@ Project name Text Maybe desc Text Maybe nextTicket Int default=1 + wiki RepoId Maybe UniqueProject ident sharer diff --git a/config/routes b/config/routes index d91a10f..ac677fa 100644 --- a/config/routes +++ b/config/routes @@ -99,5 +99,4 @@ /s/#ShrIdent/p/#PrjIdent/t/#Int/d/!reply TicketTopReplyR GET /s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Int/reply TicketReplyR GET --- /s/#ShrIdent/p/#PrjIdent/w WikiR GET --- /s/#ShrIdent/p/#PrjIdent/w/+Texts WikiPageR GET +/s/#ShrIdent/p/#PrjIdent/w/+Texts WikiPageR GET diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index eeeb75d..79a75a4 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -62,6 +62,7 @@ import Vervis.Handler.Repo import Vervis.Handler.Role import Vervis.Handler.Sharer import Vervis.Handler.Ticket +import Vervis.Handler.Wiki import Vervis.Ssh (runSsh) diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs index 82acab6..aa68742 100644 --- a/src/Vervis/Darcs.hs +++ b/src/Vervis/Darcs.hs @@ -15,14 +15,18 @@ module Vervis.Darcs ( readSourceView + , readWikiView , readChangesView ) where -import Prelude +import Prelude hiding (lookup) +import Control.Applicative ((<|>)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) +import Data.Bool (bool) +import Data.Maybe (listToMaybe, mapMaybe) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (strictDecode) @@ -52,6 +56,7 @@ import Vervis.Changes import Vervis.Foundation (Widget) import Vervis.Readme import Vervis.SourceTree +import Vervis.Wiki (WikiView (..)) dirToAnchoredPath :: [EntryName] -> AnchoredPath dirToAnchoredPath = AnchoredPath . map (Name . encodeUtf8) @@ -91,6 +96,13 @@ itemToSourceView name (SubTree tree) = do } itemToSourceView _name (Stub _load _hash) = error "supposed to be expanded" +readStubbedTree :: FilePath -> IO (Tree IO) +readStubbedTree path = do + let darcsDir = path "_darcs" + (msize, hash) <- readPristineRoot darcsDir + let pristineDir = darcsDir "pristine.hashed" + readDarcsHashed pristineDir (msize, hash) + readSourceView :: FilePath -- ^ Repository path @@ -98,10 +110,7 @@ readSourceView -- ^ Path in the source tree pointing to a file or directory -> IO (Maybe (SourceView Widget)) readSourceView path dir = do - let darcsDir = path "_darcs" - (msize, hash) <- readPristineRoot darcsDir - let pristineDir = darcsDir "pristine.hashed" - stubbedTree <- readDarcsHashed pristineDir (msize, hash) + stubbedTree <- readStubbedTree path msv <- if null dir then do let items = listImmediate stubbedTree @@ -118,6 +127,56 @@ readSourceView path dir = do for mitem $ itemToSourceView (last dir) return $ renderSources dir <$> msv +readWikiView + :: (EntryName -> EntryName -> Maybe Text) + -- ^ Page name predicate. Returns 'Nothing' for a file which isn't a page. + -- For a page file, returns 'Just' the page name, which is the filename + -- with some parts possibly removed or added. For example, you may wish to + -- remove any extensions, replace underscores with spaces and so on. + -> (EntryName -> Bool) + -- ^ Main page predicate. This is used to pick a top-level page to display + -- as the wiki root page. + -> FilePath + -- ^ Repository path. + -> [EntryName] + -- ^ Path in the source tree pointing to a file. The last component doesn't + -- have to be the full name of the file though, but it much match the page + -- predicate for the actual file to be found. + -> IO (Maybe WikiView) +readWikiView isPage isMain path dir = do + stubbedTree <- readStubbedTree path + let (parent, ispage, mfile) = + if null dir + then + ( [] + , bool Nothing (Just Nothing) . isMain + , Nothing + ) + else + ( init dir + , maybe Nothing (Just . Just) . isPage lst + , Just $ Name $ encodeUtf8 lst + ) + where + lst = last dir + anch = dirToAnchoredPath parent + matchBlob f (n, (File (Blob load _))) = f (nameToText n) load + matchBlob _ _ = Nothing + matchBlob' f (File (Blob load _)) = Just $ f load + matchBlob' _ _ = Nothing + page name load = (,) load . Just <$> ispage name + matchP = listToMaybe . mapMaybe (matchBlob page) . listImmediate + matchF t = mfile >>= lookup t >>= matchBlob' (flip (,) Nothing) + expandedTree <- expandPath stubbedTree anch + let mpage = case find expandedTree anch of + Nothing -> Nothing + Just (File _) -> Nothing + Just (Stub _ _) -> error "supposed to be expanded" + Just (SubTree tree) -> matchP tree <|> matchF tree + mkview Nothing b = WikiViewRaw b + mkview (Just mt) b = WikiViewPage mt b + for mpage $ \ (load, mmtitle) -> mkview mmtitle <$> load + readChangesView :: FilePath -- ^ Repository path diff --git a/src/Vervis/Form/Project.hs b/src/Vervis/Form/Project.hs index b7c7932..57f6524 100644 --- a/src/Vervis/Form/Project.hs +++ b/src/Vervis/Form/Project.hs @@ -38,6 +38,7 @@ newProjectAForm sid = Project <*> aopt textField "Name" Nothing <*> aopt textField "Description" Nothing <*> pure 1 + <*> pure Nothing newProjectForm :: SharerId -> Form Project newProjectForm = renderDivs . newProjectAForm diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index c1dd2a6..eb014d0 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -391,3 +391,5 @@ instance YesodBreadcrumbs App where , Just $ TicketMessageR shar proj num cnum ) + + WikiPageR shr prj _page -> ("Wiki", Just $ ProjectR shr prj) diff --git a/src/Vervis/Handler/Wiki.hs b/src/Vervis/Handler/Wiki.hs new file mode 100644 index 0000000..d09c676 --- /dev/null +++ b/src/Vervis/Handler/Wiki.hs @@ -0,0 +1,76 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Handler.Wiki + ( getWikiPageR + ) +where + +import Prelude + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Traversable (for) +import Database.Persist (Entity (..), getJust) +import Text.Blaze.Html (Html) +import Yesod.Core (defaultLayout) +import Yesod.Core.Content (toContent, typeOctet) +import Yesod.Core.Handler (setMessage, redirect, notFound, sendResponse) +import Yesod.Persist.Core (runDB, getBy404) + +import Text.FilePath.Local (breakExt) +import Vervis.Darcs +import Vervis.Foundation +import Vervis.MediaType +import Vervis.Model +import Vervis.Model.Ident +import Vervis.Model.Repo +import Vervis.Path (askRepoDir) +import Vervis.Render (renderSourceBL) +import Vervis.Settings (widgetFile) +import Vervis.Wiki + +getWikiPageR :: ShrIdent -> PrjIdent -> [Text] -> Handler Html +getWikiPageR shr prj path = do + m <- runDB $ do + Entity sid _ <- getBy404 $ UniqueSharer shr + Entity _ j <- getBy404 $ UniqueProject prj sid + for (projectWiki j) $ \ rid -> do + r <- getJust rid + s <- getJust $ repoSharer r + return (sharerIdent s, repoIdent r, repoVcs r) + case m of + Nothing -> do + setMessage "This project doesn’t have a wiki." + redirect $ ProjectR shr prj + Just (s, r, v) -> do + root <- askRepoDir s r + case v of + VCSDarcs -> do + let ispage name file = + let (b, e) = breakExt file + in if e == "md" && b == name + then Just b + else Nothing + ismain = (== "README.md") + mwv <- liftIO $ readWikiView ispage ismain root path + case mwv of + Nothing -> notFound + Just (WikiViewRaw b) -> + sendResponse (typeOctet, toContent b) + Just (WikiViewPage mt b) -> do + let page = renderSourceBL Markdown b + defaultLayout $(widgetFile "wiki") + VCSGit -> error "Not implemented yet" diff --git a/src/Vervis/Wiki.hs b/src/Vervis/Wiki.hs new file mode 100644 index 0000000..7ab8f76 --- /dev/null +++ b/src/Vervis/Wiki.hs @@ -0,0 +1,35 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Wiki + ( WikiView (..) + ) +where + +import Prelude + +import Data.Text (Text) + +import qualified Data.ByteString.Lazy as BL (ByteString) + +import Text.FilePath.Local (breakExt) +import Vervis.Foundation (Widget) +import Vervis.MediaType (chooseMediaType) +import Vervis.Readme (renderReadme) +import Vervis.Render (renderSourceBL) + +data WikiView + = WikiViewPage (Maybe Text) BL.ByteString + | WikiViewRaw BL.ByteString diff --git a/templates/wiki.hamlet b/templates/wiki.hamlet new file mode 100644 index 0000000..de765da --- /dev/null +++ b/templates/wiki.hamlet @@ -0,0 +1,18 @@ +$# This file is part of Vervis. +$# +$# Written in 2016 by fr33domlover . +$# +$# ♡ Copying is an act of love. Please copy, reuse and share. +$# +$# The author(s) have dedicated all copyright and related and neighboring +$# rights to this software to the public domain worldwide. This software is +$# distributed without any warranty. +$# +$# You should have received a copy of the CC0 Public Domain Dedication along +$# with this software. If not, see +$# . + +$maybe title <- mt +

#{title} + +^{page} diff --git a/vervis.cabal b/vervis.cabal index dc5fd84..6ce0d16 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -113,6 +113,7 @@ library Vervis.Handler.Role Vervis.Handler.Sharer Vervis.Handler.Ticket + Vervis.Handler.Wiki Vervis.Import Vervis.Import.NoFoundation Vervis.MediaType @@ -136,6 +137,7 @@ library Vervis.Widget.Discussion Vervis.Widget.Repo Vervis.Widget.Sharer + Vervis.Wiki -- other-modules: default-extensions: TemplateHaskell QuasiQuotes