Initial minimal optional per-project wiki

config/models

@@ -103,6 +103,7 @@ Project
     name       Text     Maybe
     desc       Text     Maybe
     nextTicket Int            default=1
+    wiki       RepoId   Maybe
 
     UniqueProject ident sharer
 

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

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)
 

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"
+    stubbedTree <- readStubbedTree path
-    (msize, hash) <- readPristineRoot darcsDir
-    let pristineDir = darcsDir </> "pristine.hashed"
-    stubbedTree <- readDarcsHashed pristineDir (msize, hash)
     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

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

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)

src/Vervis/Handler/Wiki.hs

@@ -0,0 +1,76 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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"

src/Vervis/Wiki.hs

@@ -0,0 +1,35 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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

templates/wiki.hamlet

@@ -0,0 +1,18 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ 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
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+$maybe title <- mt
+  <h2>#{title}
+
+^{page}

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