Refactor git source view code and implement the same for Darcs

config/routes

@@ -43,7 +43,7 @@
 /u/#Text/r                              ReposR            GET POST
 /u/#Text/r/!new                         RepoNewR          GET
 /u/#Text/r/#Text                        RepoR             GET
-/u/#Text/r/#Text/s/#Text/+Texts         RepoSourceR       GET
+/u/#Text/r/#Text/s/+Texts               RepoSourceR       GET
 /u/#Text/r/#Text/c                      RepoCommitsR      GET
 
 /u/#Text/r/#Text/git/info/refs          GitRefDiscoverR   GET

src/Darcs/Local.hs

@@ -14,17 +14,24 @@
  -}
 
 module Darcs.Local
-    ( createRepo
+    ( -- * Initialize new repo
+      createRepo
+      -- * View repo source
+    , readPristineRoot
     )
 where
 
 import Prelude
 
+import Storage.Hashed.Hash
 import System.Directory (createDirectory)
 import System.Exit (ExitCode (..))
 import System.FilePath ((</>))
+import System.IO (withFile, IOMode (ReadMode))
 import System.Process (createProcess, proc, waitForProcess)
 
+import qualified Data.ByteString as B
+
 {-
 initialRepoTree :: FileName -> DirTree B.ByteString
 initialRepoTree repo =
@@ -63,3 +70,55 @@ createRepo parent name = do
     case ec of
         ExitSuccess   -> return ()
         ExitFailure n -> error $ "darcs init failed with exit code " ++ show n
+
+{-data DirEntry = DirEntry
+    { dentType :: ItemType
+    , dentName :: Name
+    , dentSize :: Maybe Int
+    , dentHash :: Hash
+    }
+
+data DirEntryView = DirEntryView
+    { devName    :: Name
+    , devSize    :: Maybe Size
+    , devHash    :: Hash
+    , devContent :: Either BL.ByteString [DirEntry]
+    }
+
+data PathView
+    = RootView [DirEntry]
+    | TreeView Text Hash [DirEntry]
+    | BlobView Text Hash BL.ByteString
+-}
+
+readPristineRoot :: FilePath -> IO (Maybe Int, Hash)
+readPristineRoot darcsDir = do
+    let inventoryFile = darcsDir </> "hashed_inventory"
+    line <- withFile inventoryFile ReadMode B.hGetLine
+    let hashBS = B.drop 9 line
+    return (Nothing, decodeBase16 hashBS)
+
+{-toDEnt :: (ItemType, Name, Maybe Int, Hash) -> DirEntry
+toDEnt (it, n, ms, h) = DirEntry it n ms h
+
+readSourceRootDir :: FilePath -> (Maybe Int, Hash) -> IO [DirEntry]
+readSourceRootDir darcsDir (size, hash) =
+    let pristineDir = darcsDir </> "pristine.hashed"
+    in  map toDEnt <$> readDarcsHashedDir pristineDir (size, hash)
+
+findDirEntry :: Name -> [DirEntry] -> Maybe DirEntry
+findDirEntry name = find ((== name) . dentName)
+
+viewDirEntry :: FilePath -> DirEntry -> IO DirEntryView
+viewDirEntry pristineDir (DirEntry itype name size hash) = do
+    content <- case itype of
+        TreeType ->
+        BlobType -> fmap decompress . readSegment . darcsLocation pristineDir
+    return (name, size, hash, content)
+
+textToName :: Text -> Name
+textToName = Name . encodeUtf8
+
+viewPath :: FilePath -> [Name] -> IO PathView
+viewPath repoPath sourcePath = --TODO
+-}

src/Vervis/Darcs.hs

@@ -0,0 +1,103 @@
+{- 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.Darcs
+    ( readSourceView
+    )
+where
+
+import Prelude
+
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
+import Data.Text.Encoding.Error (strictDecode)
+import Data.Traversable (for)
+import Storage.Hashed.AnchoredPath
+import Storage.Hashed.Darcs
+import Storage.Hashed.Tree
+import System.FilePath ((</>))
+
+import qualified Data.ByteString.Lazy as BL (ByteString)
+import qualified Data.Foldable as F (find)
+
+import Darcs.Local
+import Vervis.Foundation (Widget)
+import Vervis.Readme
+import Vervis.SourceTree
+
+dirToAnchoredPath :: [EntryName] -> AnchoredPath
+dirToAnchoredPath = AnchoredPath . map (Name . encodeUtf8)
+
+matchType :: ItemType -> EntryType
+matchType TreeType = TypeTree
+matchType BlobType = TypeBlob
+
+nameToText :: Name -> Text
+nameToText (Name b) = decodeUtf8With strictDecode b
+
+itemToEntry :: Name -> TreeItem IO -> DirEntry
+itemToEntry name item = DirEntry (matchType $ itemType item) (nameToText name)
+
+findReadme :: [(Name, TreeItem IO)] -> IO (Maybe (Text, BL.ByteString))
+findReadme pairs =
+    case F.find (isReadme . nameToText . fst) pairs of
+        Nothing           -> return Nothing
+        Just (name, item) ->
+            case item of
+                File (Blob load _hash) -> do
+                    content <- load
+                    return $ Just (nameToText name, content)
+                _ -> return Nothing
+
+itemToSourceView :: EntryName -> TreeItem IO -> IO (SourceView BL.ByteString)
+itemToSourceView name (File (Blob load _hash)) = do
+    content <- load
+    return $ SourceFile $ FileView name content
+itemToSourceView name (SubTree tree) = do
+    let items = listImmediate tree
+    mreadme <- findReadme items
+    return $ SourceDir DirectoryView
+        { dvName    = Just name
+        , dvEntries = map (uncurry itemToEntry) items
+        , dvReadme  = mreadme
+        }
+itemToSourceView _name (Stub _load _hash) = error "supposed to be expanded"
+
+readSourceView
+    :: FilePath
+    -- ^ Repository path
+    -> [EntryName]
+    -- ^ 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)
+    msv <- if null dir
+        then do
+            let items = listImmediate stubbedTree
+            mreadme <- findReadme items
+            return $ Just $ SourceDir DirectoryView
+                { dvName    = Nothing
+                , dvEntries = map (uncurry itemToEntry) items
+                , dvReadme  = mreadme
+                }
+        else do
+            let anch = dirToAnchoredPath dir
+            expandedTree <- expandPath stubbedTree anch
+            let mitem = find expandedTree anch
+            for mitem $ itemToSourceView (last dir)
+    return $ renderSources dir <$> msv

src/Vervis/Foundation.hs

@@ -267,11 +267,11 @@ instance YesodBreadcrumbs App where
         ReposR shar                      -> ("Repos", Just $ PersonR shar)
         RepoNewR shar                    -> ("New", Just $ ReposR shar)
         RepoR shar repo                  -> (repo, Just $ ReposR shar)
-        RepoSourceR shar repo branch []  -> ("Files", Just $ RepoR shar repo)
+        RepoSourceR shar repo []         -> ("Files", Just $ RepoR shar repo)
-        RepoSourceR shar repo branch dir -> ( last dir
+        RepoSourceR shar repo refdir     -> ( last refdir
                                             , Just $
-                                              RepoSourceR shar repo branch $
+                                              RepoSourceR shar repo $
-                                              init dir
+                                              init refdir
                                             )
         RepoCommitsR shar repo           -> ("History", Just $ RepoR shar repo)
 

src/Vervis/Git.hs

@@ -13,112 +13,100 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
-{- LANGUAGE OverloadedStrings #-}
-{- LANGUAGE GeneralizedNewtypeDeriving #-}
-{- LANGUAGE DeriveGeneric #-}
-
 module Vervis.Git
-    ( lastChange
+    ( readSourceView
-    , timeAgo
-    , timeAgo'
     )
 where
 
 import Prelude
 
-import Control.Monad (join)
+import Data.Foldable (find)
--- import Control.Monad.Fix (MonadFix)
--- import Control.Monad.IO.Class
--- import Control.Monad.Trans.RWS (RWST (..))
--- import Data.CaseInsensitive (CI)
-import Data.Foldable (toList)
 import Data.Git
-import Data.Git.Revision
+import Data.Git.Harder
-import Data.Git.Repository
+import Data.Git.Storage (getObject_)
--- import Data.Hashable (Hashable)
+import Data.Git.Storage.Object (Object (..))
--- import Data.HashMap.Lazy (HashMap)
+import Data.Set (Set)
--- import Data.HashSet (HashSet)
+import Data.String (fromString)
-import Data.Hourglass
+import Data.Text (Text, unpack, pack)
-import Data.Maybe (fromMaybe{-, mapMaybe-})
+import Data.Text.Encoding (encodeUtf8)
-import Data.Monoid ((<>))
-import Data.Text (Text)
--- import Data.Time.Units
--- import GHC.Generics
--- import System.Directory.Tree hiding (name, file, err)
--- import System.FilePath ((</>))
-import System.Hourglass (dateCurrent)
 
--- import qualified Control.Monad.Trans.RWS as RWS
+import qualified Data.ByteString.Lazy as BL (ByteString)
--- import qualified Data.CaseInsensitive as CI
+import qualified Data.Set as S (member, mapMonotonic)
--- import qualified Data.HashMap.Lazy as M
-import qualified Data.Text as T
 
--- | Return the subdirs of a given dir
+import Data.Git.Local
-{-subdirs :: FilePath -> IO [FilePath]
+import Vervis.Foundation (Widget)
-subdirs dir = do
+import Vervis.Readme
-    _base :/ tree <- buildL dir
+import Vervis.SourceTree
-    return $ case tree of
-        Dir _ cs ->
-            let dirName (Dir n _) = Just n
-                dirName _         = Nothing
-            in  mapMaybe dirName cs
-        _ -> []-}
 
--- | Determine the time of the last commit in a given git branch
+matchReadme :: (ModePerm, ObjId, Text, EntObjType) -> Bool
-lastBranchChange :: Git -> String -> IO GitTime
+matchReadme (_, _, name, EntObjBlob) = isReadme name
-lastBranchChange git branch = do
+matchReadme _                        = False
-    mref <- resolveRevision git $ Revision branch []
-    mco <- traverse (getCommitMaybe git) mref
-    let mtime = fmap (personTime . commitCommitter) (join mco)
-    return $ fromMaybe (error "mtime is Nothing") mtime
 
--- | Determine the time of the last commit in any branch for a given repo
+-- | Find a README file in a directory. Return the filename and the file
-lastChange :: FilePath -> IO (Maybe DateTime)
+-- content.
-lastChange path = withRepo (fromString path) $ \ git -> do
+findReadme :: Git -> TreeRows -> IO (Maybe (Text, BL.ByteString))
-     --TODO add a better intro to json-state, the docs are bad there
+findReadme git rows =
+    case find matchReadme rows of
+        Nothing                         -> return Nothing
+        Just (_perm, oid, name, _etype) -> do
+            obj <- getObject_ git (unObjId oid) True
+            return $ case obj of
+                ObjBlob b -> Just (name, blobGetContent b)
+                _         -> Nothing
 
-    names <- branchList git
+matchType :: EntObjType -> EntryType
-    times <- traverse (lastBranchChange git) $ map refNameRaw $ toList names
+matchType EntObjBlob = TypeBlob
-    let datetimes = map timeConvert times
+matchType EntObjTree = TypeTree
-    return $ if null datetimes
-        then Nothing
-        else Just $ maximum datetimes
 
-showPeriod :: Period -> Text
+rowToEntry :: (ModePerm, ObjId, Text, EntObjType) -> DirEntry
-showPeriod (Period 0 0 d) = T.pack (show d) <> " days"
+rowToEntry (_, _, name, etype) = DirEntry (matchType etype) name
-showPeriod (Period 0 m _) = T.pack (show m) <> " months"
-showPeriod (Period y _ _) = T.pack (show y) <> " years"
 
-showDuration :: Duration -> Text
+loadSourceView
-showDuration (Duration (Hours h) (Minutes m) (Seconds s) _) =
+    :: Git
-    case (h, m, s) of
+    -> Text
-        (0, 0, 0) -> "now"
+    -> [Text]
-        (0, 0, _) -> T.pack (show s) <> " seconds"
+    -> IO (Set RefName, Set RefName, Maybe (SourceView BL.ByteString))
-        (0, _, _) -> T.pack (show m) <> " minutes"
+loadSourceView git refT dir = do
-        _         -> T.pack (show h) <> " hours"
+    branches <- branchList git
+    tags <- tagList git
+    let refS = unpack refT
+        refN = RefName refS
+    msv <- if refN `S.member` branches || refN `S.member` tags
+        then do
+            tipOid <- resolveName git refS
+            mtree <- resolveTreeish git $ unObjId tipOid
+            case mtree of
+                Nothing   -> return Nothing
+                Just tree -> do
+                    let dir' = map (entName . encodeUtf8) dir
+                    view <- viewPath git tree dir'
+                    Just <$> case view of
+                        RootView rows -> do
+                            mreadme <- findReadme git rows
+                            let ents = map rowToEntry rows
+                            return $ SourceDir $
+                                DirectoryView Nothing ents mreadme
+                        TreeView name _ rows -> do
+                            mreadme <- findReadme git rows
+                            let ents = map rowToEntry rows
+                            return $ SourceDir $
+                                DirectoryView (Just name) ents mreadme
+                        BlobView name _ body ->
+                            return $ SourceFile $ FileView name body
+        else return Nothing
+    return (branches, tags, msv)
 
-showAgo :: Period -> Duration -> Text
+readSourceView
-showAgo (Period 0 0 0) d = showDuration d
+    :: FilePath
-showAgo p              _ = showPeriod p
+    -- ^ Repository path
-
+    -> Text
-fromSec :: Seconds -> (Period, Duration)
+    -- ^ Name of branch or tag
-fromSec sec =
+    -> [Text]
-    let d = 3600 * 24
+    -- ^ Path in the source tree pointing to a file or directory
-        m = 30 * d
+    -> IO (Set Text, Set Text, Maybe (SourceView Widget))
-        y = 365 * d
+    -- ^ Branches, tags, view of the selected item
-        fs (Seconds n) = fromIntegral n
+readSourceView path ref dir = do
-        (years, yrest) = sec `divMod` Seconds y
+    (bs, ts, msv) <-
-        (months, mrest) = yrest `divMod` Seconds m
+        withRepo (fromString path) $ \ git -> loadSourceView git ref dir
-        (days, drest) = mrest `divMod` Seconds d
+    let toTexts = S.mapMonotonic $ pack . refNameRaw
-    in  (Period (fs years) (fs months) (fs days), fst $ fromSeconds drest)
+    return (toTexts bs, toTexts ts, renderSources dir <$> msv)
-
-timeAgo :: DateTime -> IO Text
-timeAgo dt = do
-    now <- dateCurrent
-    return $ timeAgo' now dt
-
-timeAgo' :: DateTime -> DateTime -> Text
-timeAgo' now dt =
-    let sec = timeDiff now dt
-        (period, duration) = fromSec sec
-    in  showAgo period duration

src/Vervis/GitOld.hs

@@ -0,0 +1,124 @@
+{- 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/>.
+ -}
+
+{- LANGUAGE OverloadedStrings #-}
+{- LANGUAGE GeneralizedNewtypeDeriving #-}
+{- LANGUAGE DeriveGeneric #-}
+
+module Vervis.GitOld
+    ( lastChange
+    , timeAgo
+    , timeAgo'
+    )
+where
+
+import Prelude
+
+import Control.Monad (join)
+-- import Control.Monad.Fix (MonadFix)
+-- import Control.Monad.IO.Class
+-- import Control.Monad.Trans.RWS (RWST (..))
+-- import Data.CaseInsensitive (CI)
+import Data.Foldable (toList)
+import Data.Git
+import Data.Git.Revision
+import Data.Git.Repository
+-- import Data.Hashable (Hashable)
+-- import Data.HashMap.Lazy (HashMap)
+-- import Data.HashSet (HashSet)
+import Data.Hourglass
+import Data.Maybe (fromMaybe{-, mapMaybe-})
+import Data.Monoid ((<>))
+import Data.Text (Text)
+-- import Data.Time.Units
+-- import GHC.Generics
+-- import System.Directory.Tree hiding (name, file, err)
+-- import System.FilePath ((</>))
+import System.Hourglass (dateCurrent)
+
+-- import qualified Control.Monad.Trans.RWS as RWS
+-- import qualified Data.CaseInsensitive as CI
+-- import qualified Data.HashMap.Lazy as M
+import qualified Data.Text as T
+
+-- | Return the subdirs of a given dir
+{-subdirs :: FilePath -> IO [FilePath]
+subdirs dir = do
+    _base :/ tree <- buildL dir
+    return $ case tree of
+        Dir _ cs ->
+            let dirName (Dir n _) = Just n
+                dirName _         = Nothing
+            in  mapMaybe dirName cs
+        _ -> []-}
+
+-- | Determine the time of the last commit in a given git branch
+lastBranchChange :: Git -> String -> IO GitTime
+lastBranchChange git branch = do
+    mref <- resolveRevision git $ Revision branch []
+    mco <- traverse (getCommitMaybe git) mref
+    let mtime = fmap (personTime . commitCommitter) (join mco)
+    return $ fromMaybe (error "mtime is Nothing") mtime
+
+-- | Determine the time of the last commit in any branch for a given repo
+lastChange :: FilePath -> IO (Maybe DateTime)
+lastChange path = withRepo (fromString path) $ \ git -> do
+     --TODO add a better intro to json-state, the docs are bad there
+
+    names <- branchList git
+    times <- traverse (lastBranchChange git) $ map refNameRaw $ toList names
+    let datetimes = map timeConvert times
+    return $ if null datetimes
+        then Nothing
+        else Just $ maximum datetimes
+
+showPeriod :: Period -> Text
+showPeriod (Period 0 0 d) = T.pack (show d) <> " days"
+showPeriod (Period 0 m _) = T.pack (show m) <> " months"
+showPeriod (Period y _ _) = T.pack (show y) <> " years"
+
+showDuration :: Duration -> Text
+showDuration (Duration (Hours h) (Minutes m) (Seconds s) _) =
+    case (h, m, s) of
+        (0, 0, 0) -> "now"
+        (0, 0, _) -> T.pack (show s) <> " seconds"
+        (0, _, _) -> T.pack (show m) <> " minutes"
+        _         -> T.pack (show h) <> " hours"
+
+showAgo :: Period -> Duration -> Text
+showAgo (Period 0 0 0) d = showDuration d
+showAgo p              _ = showPeriod p
+
+fromSec :: Seconds -> (Period, Duration)
+fromSec sec =
+    let d = 3600 * 24
+        m = 30 * d
+        y = 365 * d
+        fs (Seconds n) = fromIntegral n
+        (years, yrest) = sec `divMod` Seconds y
+        (months, mrest) = yrest `divMod` Seconds m
+        (days, drest) = mrest `divMod` Seconds d
+    in  (Period (fs years) (fs months) (fs days), fst $ fromSeconds drest)
+
+timeAgo :: DateTime -> IO Text
+timeAgo dt = do
+    now <- dateCurrent
+    return $ timeAgo' now dt
+
+timeAgo' :: DateTime -> DateTime -> Text
+timeAgo' now dt =
+    let sec = timeDiff now dt
+        (period, duration) = fromSec sec
+    in  showAgo period duration

src/Vervis/Handler/Home.hs

@@ -21,7 +21,7 @@ where
 import Vervis.Import hiding (on)
 
 import Database.Esqueleto hiding ((==.))
-import Vervis.Git
+import Vervis.GitOld
 
 import qualified Database.Esqueleto as E ((==.))
 

src/Vervis/Handler/Repo.hs

@@ -66,7 +66,7 @@ import Data.Git.Local
 import Text.FilePath.Local (breakExt)
 import Vervis.Form.Repo
 import Vervis.Foundation
-import Vervis.Git (timeAgo')
+import Vervis.GitOld (timeAgo')
 import Vervis.Path
 import Vervis.MediaType (chooseMediaType)
 import Vervis.Model
@@ -74,11 +74,14 @@ import Vervis.Model.Repo
 import Vervis.Readme
 import Vervis.Render
 import Vervis.Settings
+import Vervis.SourceTree
 import Vervis.Style
 
 import qualified Darcs.Local as D (createRepo)
 import qualified Data.ByteString.Lazy as BL (ByteString)
 import qualified Data.Git.Local as G (createRepo)
+import qualified Vervis.Darcs as D (readSourceView)
+import qualified Vervis.Git as G (readSourceView)
 
 getReposR :: Text -> Handler Html
 getReposR user = do
@@ -136,62 +139,19 @@ getRepoR user repo = do
         Entity sid _s <- getBy404 $ UniqueSharerIdent user
         Entity _rid r <- getBy404 $ UniqueRepo repo sid
         return r
-    getRepoSource repository user repo (repoMainBranch repository) []
+    case repoVcs repository of
+        VCSDarcs -> getDarcsRepoSource repository user repo []
+        VCSGit ->
+            getGitRepoSource
+                repository user repo (repoMainBranch repository) []
 
-data SourceView a
+getDarcsRepoSource :: Repo -> Text -> Text -> [Text] -> Handler Html
-    = DirectoryView (Maybe Text) TreeRows (Maybe (Text, a))
+getDarcsRepoSource repository user repo dir = do
-    | FileView Text a
-
-loadSourceView
-    :: Git
-    -> Text
-    -> [Text]
-    -> IO (Set RefName, Set RefName, Maybe (SourceView BL.ByteString))
-loadSourceView git refT dir = do
-    branches <- branchList git
-    tags <- tagList git
-    let refS = unpack refT
-        refN = RefName refS
-    msv <- if refN `S.member` branches || refN `S.member` tags
-        then do
-            tipOid <- resolveName git refS
-            mtree <- resolveTreeish git $ unObjId tipOid
-            case mtree of
-                Nothing   -> return Nothing
-                Just tree -> do
-                    let dir' = map (entName . encodeUtf8) dir
-                    view <- viewPath git tree dir'
-                    Just <$> case view of
-                        RootView rows -> do
-                            mreadme <- findReadme git rows
-                            return $ DirectoryView Nothing rows mreadme
-                        TreeView name _ rows -> do
-                            mreadme <- findReadme git rows
-                            return $ DirectoryView (Just name) rows mreadme
-                        BlobView name _ body -> return $ FileView name body
-        else return Nothing
-    return (branches, tags, msv)
-
-renderSources :: [Text] -> SourceView BL.ByteString -> SourceView Widget
-renderSources dir (DirectoryView mname rows mreadme) =
-    case mreadme of
-        Nothing -> DirectoryView mname rows Nothing
-        Just (name, body) ->
-            DirectoryView mname rows $ Just (name, renderReadme dir name body)
-renderSources dir (FileView name body) =
-    let parent = init dir
-        (base, ext) = breakExt name
-        mediaType = chooseMediaType parent base ext () ()
-    in  FileView name $ renderSourceBL mediaType body
-
-getRepoSource :: Repo -> Text -> Text -> Text -> [Text] -> Handler Html
-getRepoSource repository user repo ref dir = do
     path <- askRepoDir user repo
-    let toText = decodeUtf8With lenientDecode
+    --let toText = decodeUtf8With lenientDecode
-        toTextL = L.decodeUtf8With lenientDecode
+    --    toTextL = L.decodeUtf8With lenientDecode
-    (branches, tags, msv) <- liftIO $ withRepo (fromString path) $ \ git ->
+    msv <- liftIO $ D.readSourceView path dir
-        loadSourceView git ref dir
+    case msv of
-    case renderSources dir <$> msv of
         Nothing -> notFound
         Just sv -> do
             let parent = if null dir then [] else init dir
@@ -199,15 +159,35 @@ getRepoSource repository user repo ref dir = do
             defaultLayout $ do
                 setTitle $ toHtml $ intercalate " > " $
                     ["Vervis", "People", user, "Repos", repo]
-                $(widgetFile "repo/source")
+                $(widgetFile "repo/source-darcs")
 
-getRepoSourceR :: Text -> Text -> Text -> [Text] -> Handler Html
+getGitRepoSource :: Repo -> Text -> Text -> Text -> [Text] -> Handler Html
+getGitRepoSource repository user repo ref dir = do
+    path <- askRepoDir user repo
+    --let toText = decodeUtf8With lenientDecode
+    --    toTextL = L.decodeUtf8With lenientDecode
+    (branches, tags, msv) <- liftIO $ G.readSourceView path ref dir
+    case msv of
+        Nothing -> notFound
+        Just sv -> do
+            let parent = if null dir then [] else init dir
+                dirs = zip parent (tail $ inits parent)
+            defaultLayout $ do
+                setTitle $ toHtml $ intercalate " > " $
+                    ["Vervis", "People", user, "Repos", repo]
+                $(widgetFile "repo/source-git")
+
+getRepoSourceR :: Text -> Text -> [Text] -> Handler Html
 getRepoSourceR user repo refdir = do
     repository <- runDB $ do
         Entity sid _s <- getBy404 $ UniqueSharerIdent user
         Entity _rid r <- getBy404 $ UniqueRepo repo sid
         return r
-    getRepoSource repository user repo ref dir
+    case repoVcs repository of
+        VCSDarcs -> getDarcsRepoSource repository user repo refdir
+        VCSGit -> case refdir of
+            []           -> notFound
+            (ref:dir) -> getGitRepoSource repository user repo ref dir
 
 getRepoCommitsR :: Text -> Text -> Handler Html
 getRepoCommitsR user repo = do

src/Vervis/Readme.hs

@@ -15,7 +15,7 @@
 
 -- | Tools for rendering README files in repository tree view.
 module Vervis.Readme
-    ( findReadme
+    ( isReadme
     , renderReadme
     )
 where
@@ -43,21 +43,6 @@ isReadme file =
     let basename = takeWhile (not . isExtSeparator) file
     in  toCaseFold "readme" == toCaseFold basename
 
--- | Find a README file in a directory. Return the filename and the file
--- content.
-findReadme :: Git -> TreeRows -> IO (Maybe (Text, ByteString))
-findReadme git rows = go rows
-    where
-    go []                        = return Nothing
-    go ((_perm, oid, name, ref) : es) =
-        if isReadme name
-            then do
-                obj <- getObject_ git (unObjId oid) True
-                case obj of
-                    ObjBlob b -> return $ Just (name, blobGetContent b)
-                    _         -> go es
-            else go es
-
 -- | Render README content into a widget for inclusion in a page.
 renderReadme :: [Text] -> Text -> ByteString -> Widget
 renderReadme dir name content =

src/Vervis/SourceTree.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/>.
+ -}
+
+-- | A representation of a node (file or directory) in a file tree managed by
+-- version control.
+module Vervis.SourceTree
+    ( EntryType (..)
+    , EntryName
+    , DirEntry (..)
+    , DirectoryView (..)
+    , FileView (..)
+    , SourceView (..)
+    , renderSources
+    )
+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 EntryType = TypeBlob | TypeTree
+
+type EntryName = Text
+
+data DirEntry = DirEntry
+    { deType :: EntryType
+    , deName :: EntryName
+--    , deHash :: B.ByteString
+    }
+
+data DirectoryView a = DirectoryView
+    { dvName    :: Maybe EntryName
+    , dvEntries :: [DirEntry]
+    , dvReadme  :: Maybe (EntryName, a)
+    }
+
+data FileView a = FileView
+    { fvName    :: EntryName
+    , fvContent :: a
+    }
+
+data SourceView a
+    = SourceDir (DirectoryView a)
+    | SourceFile (FileView a)
+
+renderSources :: [EntryName] -> SourceView BL.ByteString -> SourceView Widget
+renderSources dir (SourceDir (DirectoryView mname rows mreadme)) =
+    SourceDir $ case mreadme of
+        Nothing -> DirectoryView mname rows Nothing
+        Just (name, body) ->
+            DirectoryView mname rows $ Just (name, renderReadme dir name body)
+renderSources dir (SourceFile (FileView name body)) =
+    let parent = init dir
+        (base, ext) = breakExt name
+        mediaType = chooseMediaType parent base ext () ()
+    in  SourceFile $ FileView name $ renderSourceBL mediaType body

templates/repo/source-darcs.hamlet

@@ -0,0 +1,57 @@
+$# 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 desc <- repoDesc repository
+  <p>#{desc}
+
+<p>
+  <a href=@{RepoCommitsR user repo}>Commits
+
+<h2>Branches
+
+<p>TODO
+
+<h2>Tags
+
+<p>TODO
+
+<div>
+  $forall (piece, piecePath) <- dirs
+    <a href=@{RepoSourceR user repo piecePath}>#{piece}
+    / #
+
+$case sv
+  $of SourceFile (FileView name body)
+    <h2>#{name}
+    ^{body}
+  $of SourceDir (DirectoryView mname ents mreadme)
+    <h2>#{fromMaybe "Files" mname}
+    <table>
+      <tr>
+        <th>Type
+        <th>Name
+      $forall DirEntry type' name <- ents
+        <tr>
+          <td>
+            $case type'
+              $of TypeBlob
+                [F]
+              $of TypeTree
+                [D]
+          <td>
+            <a href=@{RepoSourceR user repo (dir ++ [name])}>
+              #{name}
+    $maybe (readmeName, readmeWidget) <- mreadme
+      <h2>#{readmeName}
+      ^{readmeWidget}

templates/repo/source-git.cassius

@@ -0,0 +1,295 @@
+/* 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/>.
+ */
+
+/* Comment */
+.c
+    color: #ff0000
+    background-color: #ffffff
+
+/* Error */
+.err
+    color: #ff0000
+    background-color: #ffffff
+
+/* Keyword */
+.k
+    color: #{dark magenta}
+
+/* Comment.Multiline */
+.cm
+    color: #{dark blue}
+
+/* Comment.Preproc */
+.cp
+    color: #ff0000
+    background-color: #ffffff
+
+/* Comment.Single */
+.c1
+    color: #{dark blue}
+
+/* Comment.Special */
+.cs
+    color: #ff0000
+    background-color: #ffffff
+
+/* Generic.Deleted */
+.gd
+    color: #ff0000
+    background-color: #ffffff
+
+/* Generic.Emph */
+.ge
+    font-style: italic
+
+/* Generic.Error */
+.gr
+    color: #ff0000
+    background-color: #ffffff
+
+/* Generic.Heading */
+.gh
+    color: #ff0000
+    background-color: #ffffff
+
+/* Generic.Inserted */
+.gi
+    color: #ff0000
+    background-color: #ffffff
+
+/* Generic.Output */
+.go
+    color: #ff0000
+    background-color: #ffffff
+
+/* Generic.Prompt */
+.gp
+    color: #ff0000
+    background-color: #ffffff
+
+/* Generic.Strong */
+.gs
+    font-weight: bold
+
+/* Generic.Subheading */
+.gu
+    color: #ff0000
+    background-color: #ffffff
+
+/* Generic.Traceback */
+.gt
+    color: #ff0000
+    background-color: #ffffff
+
+/* Keyword.Constant */
+.kc
+    color: #ff0000
+    background-color: #ffffff
+
+/* Keyword.Declaration */
+.kd
+    color: #ff0000
+    background-color: #ffffff
+
+/* Keyword.Namespace */
+.kn
+    color: #ff0000
+    background-color: #ffffff
+
+/* Keyword.Pseudo */
+.kp
+    color: #ff0000
+    background-color: #ffffff
+
+/* Keyword.Reserved */
+.kr
+    color: #{dark green}
+
+/* Keyword.Type */
+.kt
+    color: #{plain}
+
+/* Literal.Number */
+.m
+    color: #ff0000
+    background-color: #ffffff
+
+/* Literal.String */
+.s
+    color: #{dark red}
+
+/* Name.Attribute */
+.na
+    color: #ff0000
+    background-color: #ffffff
+
+/* Name.Builtin */
+.nb
+    color: #{plain}
+
+/* Name.Class */
+.nc
+    color: #ff0000
+    background-color: #ffffff
+
+/* Name.Constant */
+.no
+    color: #ff0000
+    background-color: #ffffff
+
+/* Name.Decorator */
+.nd
+    color: #ff0000
+    background-color: #ffffff
+
+/* Name.Exception */
+.ne
+    color: #ff0000
+    background-color: #ffffff
+
+/* Name.Function */
+.nf
+    color: #{plain}
+
+/* Name.Label */
+.nl
+    color: #ff0000
+    background-color: #ffffff
+
+/* Name.Namespace */
+.nn
+    color: #{plain}
+
+/* Name.Property */
+.py
+    color: #ff0000
+    background-color: #ffffff
+
+/* Name.Tag */
+.nt
+    color: #ff0000
+    background-color: #ffffff
+
+/* Name.Variable */
+.nv
+    color: #ff0000
+    background-color: #ffffff
+
+/* Operator.Word */
+.ow
+    color: #{dark yellow}
+
+/* Text.Whitespace */
+.w
+    color: #ff0000
+    background-color: #ffffff
+
+/* Literal.Number.Float */
+.mf
+    color: #ff0000
+    background-color: #ffffff
+
+/* Literal.Number.Hex */
+.mh
+    color: #ff0000
+    background-color: #ffffff
+
+/* Literal.Number.Integer */
+.mi
+    color: #{dark red}
+
+/* Literal.Number.Oct */
+.mo
+    color: #ff0000
+    background-color: #ffffff
+
+/* Literal.String.Backtick */
+.sb
+    color: #ff0000
+    background-color: #ffffff
+
+/* Literal.String.Char */
+.sc
+    color: #ff0000
+    background-color: #ffffff
+
+/* Literal.String.Doc */
+.sd
+    color: #ff0000
+    background-color: #ffffff
+
+/* Literal.String.Double */
+.s2
+    color: #ff0000
+    background-color: #ffffff
+
+/* Literal.String.Escape */
+.se
+    color: #{dark magenta}
+
+/* Literal.String.Heredoc */
+.sh
+    color: #dd2200
+    background-color: #fff0f0
+
+/* Literal.String.Interpol */
+.si
+    color: #ff0000
+    background-color: #ffffff
+
+/* Literal.String.Other */
+.sx
+    color: #ff0000
+    background-color: #ffffff
+
+/* Literal.String.Regex */
+.sr
+    color: #ff0000
+    background-color: #ffffff
+
+/* Literal.String.Single */
+.s1
+    color: #ff0000
+    background-color: #ffffff
+
+/* Literal.String.Symbol */
+.ss
+    color: #ff0000
+    background-color: #ffffff
+
+/* Name.Builtin.Pseudo */
+.bp
+    color: #ff0000
+    background-color: #ffffff
+
+/* Name.Variable.Class */
+.vc
+    color: #ff0000
+    background-color: #ffffff
+
+/* Name.Variable.Global */
+.vg
+    color: #ff0000
+    background-color: #ffffff
+
+/* Name.Variable.Instance */
+.vi
+    color: #ff0000
+    background-color: #ffffff
+
+/* Literal.Number.Integer.Long */
+.il
+    color: #ff0000
+    background-color: #ffffff

templates/repo/source-git.hamlet

@@ -21,44 +21,44 @@ $maybe desc <- repoDesc repository
 <h2>Branches
 
 <ul>
-$forall RefName branch <- branches
+$forall branch <- branches
   <li>
-    <a href=@{RepoSourceR user repo (pack branch) []}>#{branch}
+    <a href=@{RepoSourceR user repo [branch]}>#{branch}
 
 <h2>Tags
 
 <ul>
-$forall RefName tag <- tags
+$forall tag <- tags
   <li>
-    <a href=@{RepoSourceR user repo (pack tag) []}>#{tag}
+    <a href=@{RepoSourceR user repo [tag]}>#{tag}
 
 <div>
-  <a href=@{RepoSourceR user repo ref []}>#{ref}
+  <a href=@{RepoSourceR user repo [ref]}>#{ref}
   :: #
   $forall (piece, piecePath) <- dirs
-    <a href=@{RepoSourceR user repo ref piecePath}>#{piece}
+    <a href=@{RepoSourceR user repo (ref : piecePath)}>#{piece}
     / #
 
 $case sv
-  $of FileView name body
+  $of SourceFile (FileView name body)
     <h2>#{name}
     ^{body}
-  $of DirectoryView mname rows mreadme
+  $of SourceDir (DirectoryView mname ents mreadme)
     <h2>#{fromMaybe "Files" mname}
     <table>
       <tr>
         <th>Type
         <th>Name
-      $forall (_perm, _oid, name, type') <- rows
+      $forall DirEntry type' name <- ents
         <tr>
           <td>
             $case type'
-              $of EntObjBlob
+              $of TypeBlob
                 [F]
-              $of EntObjTree
+              $of TypeTree
                 [D]
           <td>
-            <a href=@{RepoSourceR user repo ref (dir ++ [name])}>
+            <a href=@{RepoSourceR user repo (ref : (dir ++ [name]))}>
               #{name}
     $maybe (readmeName, readmeWidget) <- mreadme
       <h2>#{readmeName}

vervis.cabal

@@ -47,6 +47,7 @@ library
                        Vervis.Application
                        Vervis.BinaryBody
                        Vervis.Content
+                       Vervis.Darcs
                        Vervis.Field.Key
                        Vervis.Field.Person
                        Vervis.Field.Project
@@ -58,15 +59,7 @@ library
                        Vervis.Form.Ticket
                        Vervis.Foundation
                        Vervis.Git
-                       Vervis.Import
+                       Vervis.GitOld
-                       Vervis.Import.NoFoundation
-                       Vervis.MediaType
-                       Vervis.Model
-                       Vervis.Model.Repo
-                       Vervis.Readme
-                       Vervis.Render
-                       Vervis.Settings
-                       Vervis.Settings.StaticFiles
                        Vervis.Handler.Common
                        Vervis.Handler.Git
                        Vervis.Handler.Home
@@ -76,7 +69,17 @@ library
                        Vervis.Handler.Repo
                        Vervis.Handler.Ticket
                        Vervis.Handler.Util
+                       Vervis.Import
+                       Vervis.Import.NoFoundation
+                       Vervis.MediaType
+                       Vervis.Model
+                       Vervis.Model.Repo
                        Vervis.Path
+                       Vervis.Readme
+                       Vervis.Render
+                       Vervis.Settings
+                       Vervis.Settings.StaticFiles
+                       Vervis.SourceTree
                        Vervis.Ssh
                        Vervis.Style
                        Vervis.Widget
@@ -100,9 +103,9 @@ library
   build-depends:       aeson
                      , attoparsec
                      , base
+                     , base64-bytestring
                        -- for Data.Binary.Local
                      , binary
-                     , base64-bytestring
                      , blaze-html
                      , byteable
                      , bytestring
@@ -111,6 +114,9 @@ library
                      , classy-prelude-conduit
                      , conduit
                      , containers
+                       -- for Storage.Hashed because hashed-storage seems
+                       -- unmaintained and darcs has its own copy
+                     , darcs
                      , data-default
                      , directory
                        -- for Data.Git.Local