Split git repo source handler into sane small functions

src/Darcs/Local.hs

@@ -14,7 +14,7 @@
  -}
 
 module Darcs.Local
-    ( initRepo
+    ( createRepo
     )
 where
 
@@ -48,13 +48,13 @@ initialRepoTree repo =
 -}
 
 -- | initialize a new bare repository at a specific location.
-initRepo
+createRepo
     :: FilePath
     -- ^ Parent directory which already exists
     -> String
     -- ^ Name of new repo, i.e. new directory to create under the parent
     -> IO ()
-initRepo parent name = do
+createRepo parent name = do
     let path = parent </> name
     createDirectory path
     let settings = proc "darcs" ["init", "--no-working-dir", path]

src/Data/Git/Local.hs

@@ -14,44 +14,45 @@
  -}
 
 module Data.Git.Local
-    ( initRepo
+    ( -- * Initialize repo
+      createRepo
+      -- * View repo content
+    , EntObjType (..)
+    , TreeRows
+    , PathView (..)
+    , viewPath
     )
 where
 
 import Prelude
 
 import Control.Monad (when)
+import Data.Byteable (toBytes)
+import Data.Git
+import Data.Git.Harder
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8With)
+import Data.Text.Encoding.Error (lenientDecode)
 import System.Directory.Tree
 
 import qualified Data.ByteString as B (ByteString, writeFile)
-
+import qualified Data.ByteString.Lazy as BL (ByteString)
-initialConfig :: B.ByteString
-initialConfig =
-    "[core]\n\
-    \    repositoryformatversion = 0\n\
-    \    filemode = true\n\
-    \    bare = true"
-
-initialDescription :: B.ByteString
-initialDescription =
-    "Unnamed repository; edit this file to name the repository."
-
-initialHead :: B.ByteString
-initialHead = "ref: refs/heads/master"
-
-initialExclude :: B.ByteString
-initialExclude = ""
 
 initialRepoTree :: FileName -> DirTree B.ByteString
 initialRepoTree repo =
     Dir repo
         [ Dir "branches" []
-        , File "config" initialConfig
+        , File "config"
-        , File "description" initialDescription
+            "[core]\n\
-        , File "HEAD" initialHead
+            \    repositoryformatversion = 0\n\
+            \    filemode = true\n\
+            \    bare = true"
+        , File "description"
+            "Unnamed repository; edit this file to name the repository."
+        , File "HEAD" "ref: refs/heads/master"
         , Dir "hooks" []
         , Dir "info"
-            [ File "exclude" initialExclude
+            [ File "exclude" ""
             ]
         , Dir "objects"
             [ Dir "info" []
@@ -68,14 +69,41 @@ initialRepoTree repo =
 -- Currently in the @hit@ package, i.e. version 0.6.3, the initRepo function
 -- creates a directory which the git executable doesn't recognize as a git
 -- repository. The version here creates a properly initialized repo.
-initRepo
+createRepo
     :: FilePath
     -- ^ Parent directory which already exists
     -> String
     -- ^ Name of new repo, i.e. new directory to create under the parent
     -> IO ()
-initRepo path name = do
+createRepo path name = do
     let tree = path :/ initialRepoTree name
     result <- writeDirectoryWith B.writeFile tree
     let errs = failures $ dirTree result
     when (not . null $ errs) $ error $ show errs
+
+data EntObjType = EntObjBlob | EntObjTree
+
+type TreeRows = [(ModePerm, ObjId, Text, EntObjType)]
+
+data PathView
+    = RootView TreeRows
+    | TreeView Text ObjId TreeRows
+    | BlobView Text ObjId BL.ByteString
+
+viewPath :: Git -> Tree -> EntPath -> IO PathView
+viewPath git root path = do
+    let toEnt False = EntObjBlob
+        toEnt True  = EntObjTree
+        toText = decodeUtf8With lenientDecode . toBytes
+        adapt (perm, oid, name, isTree) =
+            (perm, oid, toText name, toEnt isTree)
+        mkRows t = map adapt <$> viewTree git t
+    mno <- resolveTreePath git root path
+    case mno of
+        Nothing          -> RootView <$> mkRows root
+        Just (name, oid) -> do
+            let nameT = toText name
+            target <- getEntryObject_ git oid
+            case target of
+                Left blob  -> return $ BlobView nameT oid (blobGetContent blob)
+                Right tree -> TreeView nameT oid <$> mkRows tree

src/Vervis/Handler/Repo.hs

@@ -32,20 +32,18 @@ where
 -- [x] write the git and mkdir parts that actually create the repo
 -- [x] make repo view that shows a table of commits
 
-import ClassyPrelude.Conduit       hiding (last, toStrict, unpack)
+import ClassyPrelude.Conduit       hiding (last, unpack)
 import Yesod                       hiding (Header, parseTime, (==.))
 import Yesod.Auth
 
 import Prelude (init, last, tail)
 
-import Data.Byteable (toBytes)
-import Data.ByteString.Lazy (toStrict)
 import Data.Git.Graph
 import Data.Git.Harder
 import Data.Git.Named (RefName (..))
 import Data.Git.Ref (toHex)
 import Data.Git.Repository
-import Data.Git.Storage (withRepo, getObject_)
+import Data.Git.Storage (withRepo)
 import Data.Git.Storage.Object (Object (..))
 import Data.Git.Types (Blob (..), Commit (..), Person (..), entName)
 import Data.Graph.Inductive.Graph (noNodes)
@@ -64,6 +62,7 @@ import qualified Data.Set as S (member)
 import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
 
 import Data.ByteString.Char8.Local (takeLine)
+import Data.Git.Local
 import Text.FilePath.Local (breakExt)
 import Vervis.Form.Repo
 import Vervis.Foundation
@@ -77,8 +76,9 @@ import Vervis.Render
 import Vervis.Settings
 import Vervis.Style
 
-import qualified Darcs.Local as D (initRepo)
+import qualified Darcs.Local as D (createRepo)
-import qualified Data.Git.Local as G (initRepo)
+import qualified Data.ByteString.Lazy as BL (ByteString)
+import qualified Data.Git.Local as G (createRepo)
 
 getReposR :: Text -> Handler Html
 getReposR user = do
@@ -105,8 +105,8 @@ postReposR user = do
                 createDirectoryIfMissing True parent
                 let repoName = unpack $ repoIdent repo
                 case repoVcs repo of
-                    VCSDarcs -> D.initRepo parent repoName
+                    VCSDarcs -> D.createRepo parent repoName
-                    VCSGit   -> G.initRepo parent repoName
+                    VCSGit   -> G.createRepo parent repoName
             runDB $ insert_ repo
             setMessage "Repo added."
             redirect $ ReposR user
@@ -138,66 +138,64 @@ getRepoR user repo = do
         return r
     getRepoSource repository user repo (repoMainBranch repository) []
 
-getRepoSource :: Repo -> Text -> Text -> Text -> [Text] -> Handler Html
+data SourceView a
-getRepoSource repository user repo ref dir = do
+    = DirectoryView (Maybe Text) TreeRows (Maybe (Text, a))
-    path <- askRepoDir user repo
+    | FileView Text a
-    let toText = decodeUtf8With lenientDecode
+
-        toTextL = L.decodeUtf8With lenientDecode
+loadSourceView
-    minfo <- liftIO $ withRepo (fromString path) $ \ git -> do
+    :: Git
+    -> Text
+    -> [Text]
+    -> IO (Set RefName, Set RefName, Maybe (SourceView BL.ByteString))
+loadSourceView git refT dir = do
     branches <- branchList git
     tags <- tagList git
-        let name = unpack ref
+    let refS = unpack refT
-            name' = RefName name
+        refN = RefName refS
-        if name' `S.member` branches || name' `S.member` tags
+    msv <- if refN `S.member` branches || refN `S.member` tags
         then do
-                tipOid <- resolveName git name
+            tipOid <- resolveName git refS
             mtree <- resolveTreeish git $ unObjId tipOid
             case mtree of
                 Nothing   -> return Nothing
                 Just tree -> do
                     let dir' = map (entName . encodeUtf8) dir
-                        mTargetOid <- resolveTreePath git tree dir'
+                    view <- viewPath git tree dir'
-                        target <- case mTargetOid of
+                    Just <$> case view of
-                            Nothing  -> return $ Right tree
+                        RootView rows -> do
-                            Just oid -> do
+                            mreadme <- findReadme git rows
-                                obj <- getObject_ git (unObjId oid) True
+                            return $ DirectoryView Nothing rows mreadme
-                                case obj of
+                        TreeView name _ rows -> do
-                                    ObjTree t -> return $ Right t
+                            mreadme <- findReadme git rows
-                                    ObjBlob b -> return $ Left b
+                            return $ DirectoryView (Just name) rows mreadme
-                                    _         -> error "expected tree or blob"
+                        BlobView name _ body -> return $ FileView name body
-                        view <- case target of
-                            Left b  -> Left  <$> return b
-                            Right t -> do
-                                v <- viewTree git t
-                                mreadme <- findReadme git t
-                                let r = case mreadme of
-                                            Nothing     -> Nothing
-                                            Just (t, b) ->
-                                                Just (t, renderReadme dir t b)
-                                return $ Right (v, r)
-                        return $ Just (branches, tags, view)
         else return Nothing
-    case minfo of
+    return (branches, tags, msv)
-        Nothing                     -> notFound
+
-        Just (branches, tags, view) -> do
+renderSources :: [Text] -> SourceView BL.ByteString -> SourceView Widget
-            let mkrow (_perm, name, isTree) =
+renderSources dir (DirectoryView mname rows mreadme) =
-                    ( if isTree then "[D]" else "[F]" :: Text
+    case mreadme of
-                    , toText $ toBytes name
+        Nothing -> DirectoryView mname rows Nothing
-                    )
+        Just (name, body) ->
-            display <- case view of
+            DirectoryView mname rows $ Just (name, renderReadme dir name body)
-                    Left b -> return $ Left $
+renderSources dir (FileView name body) =
-                        let name = last dir
+    let parent = init dir
-                            parent = init dir
         (base, ext) = breakExt name
         mediaType = chooseMediaType parent base ext () ()
-                        in  renderSourceBL mediaType (blobGetContent b)
+    in  FileView name $ renderSourceBL mediaType body
-                    Right (v, mr) -> return $ Right (map mkrow v, mr)
+
+getRepoSource :: Repo -> Text -> Text -> Text -> [Text] -> Handler Html
+getRepoSource repository user repo ref dir = do
+    path <- askRepoDir user repo
+    let toText = decodeUtf8With lenientDecode
+        toTextL = L.decodeUtf8With lenientDecode
+    (branches, tags, msv) <- liftIO $ withRepo (fromString path) $ \ git ->
+        loadSourceView git ref dir
+    case renderSources dir <$> msv of
+        Nothing -> notFound
+        Just sv -> do
             let parent = if null dir then [] else init dir
                 dirs = zip parent (tail $ inits parent)
-                title = case (dir, display) of
-                    ([], _)      -> "Files"
-                    (_,  Left _) -> last dir
-                    (_, Right _) -> last dir <> "/"
             defaultLayout $ do
                 setTitle $ toHtml $ intercalate " > " $
                     ["Vervis", "People", user, "Repos", repo]

src/Vervis/Readme.hs

@@ -22,20 +22,19 @@ where
 
 import Prelude hiding (takeWhile)
 
-import Data.Byteable (toBytes)
 import Data.ByteString.Lazy (ByteString)
+import Data.Git.Harder (ObjId (..))
 import Data.Git.Storage (Git, getObject_)
 import Data.Git.Storage.Object (Object (..))
 import Data.Git.Types (Blob (..), Tree (..))
 import Data.Text (Text, toCaseFold, takeWhile, unpack)
-import Data.Text.Encoding (decodeUtf8With)
-import Data.Text.Encoding.Error (strictDecode)
 import System.FilePath (isExtSeparator)
 
+import Data.Git.Local (TreeRows)
+import Text.FilePath.Local (breakExt)
 import Vervis.Foundation (Widget)
 import Vervis.MediaType (chooseMediaType)
 import Vervis.Render (renderSourceBL)
-import Text.FilePath.Local (breakExt)
 
 -- | Check if the given filename should be considered as README file. Assumes
 -- a flat filename which doesn't contain a directory part.
@@ -46,17 +45,16 @@ isReadme file =
 
 -- | Find a README file in a directory. Return the filename and the file
 -- content.
-findReadme :: Git -> Tree -> IO (Maybe (Text, ByteString))
+findReadme :: Git -> TreeRows -> IO (Maybe (Text, ByteString))
-findReadme git tree = go $ treeGetEnts tree
+findReadme git rows = go rows
     where
     go []                        = return Nothing
-    go ((_perm, name, ref) : es) =
+    go ((_perm, oid, name, ref) : es) =
-        let nameT = decodeUtf8With strictDecode $ toBytes name
+        if isReadme name
-        in  if isReadme nameT
             then do
-                    obj <- getObject_ git ref True
+                obj <- getObject_ git (unObjId oid) True
                 case obj of
-                        ObjBlob b -> return $ Just (nameT, blobGetContent b)
+                    ObjBlob b -> return $ Just (name, blobGetContent b)
                     _         -> go es
             else go es
 

templates/repo/source.hamlet

@@ -19,34 +19,44 @@ $maybe desc <- repoDesc repository
   <a href=@{RepoCommitsR user repo}>Commits
 
 <h2>Branches
+
 <ul>
 $forall RefName branch <- branches
   <li>
     <a href=@{RepoSourceR user repo (pack branch) []}>#{branch}
 
 <h2>Tags
+
 <ul>
 $forall RefName tag <- tags
   <li>
     <a href=@{RepoSourceR user repo (pack tag) []}>#{tag}
 
+<div>
   <a href=@{RepoSourceR user repo ref []}>#{ref}
-<span>::
+  :: #
   $forall (piece, piecePath) <- dirs
     <a href=@{RepoSourceR user repo ref piecePath}>#{piece}
-  <span>/
+    / #
-<h2>#{title}
+
-$case display
+$case sv
-  $of Left source
+  $of FileView name body
-    ^{source}
+    <h2>#{name}
-  $of Right (rows, mreadme)
+    ^{body}
+  $of DirectoryView mname rows mreadme
+    <h2>#{fromMaybe "Files" mname}
     <table>
       <tr>
         <th>Type
         <th>Name
-      $forall (type', name) <- rows
+      $forall (_perm, _oid, name, type') <- rows
         <tr>
-          <td>#{type'}
+          <td>
+            $case type'
+              $of EntObjBlob
+                [F]
+              $of EntObjTree
+                [D]
           <td>
             <a href=@{RepoSourceR user repo ref (dir ++ [name])}>
               #{name}