fix: prevent panic on parse error in repo page

src/Data/Git/Local.hs

@@ -50,6 +50,9 @@ import qualified Data.Text.IO as TIO
 import Data.EventTime.Local
 import Data.Hourglass.Local ()
 
+import Data.Traversable (for)
+import Data.Git.Storage (getObjectType)
+
 instance SpecToEventTime GitTime where
     specToEventTime = specToEventTime . gitTimeUTC
     specsToEventTimes = specsToEventTimes . fmap gitTimeUTC
@@ -129,6 +132,22 @@ data PathView
     | TreeView Text ObjId TreeRows
     | BlobView Text ObjId BL.ByteString
 
+-- | FIXME: lib/hit-harder/src/Data/Git/Harder.hs with error handling
+viewTree' :: Git SHA1 -> Tree SHA1 -> IO [(ModePerm, ObjId, EntName, Bool)]
+viewTree' git tree = for (treeGetEnts tree) $ \ (perm, name, ref) -> do
+    -- Handle error when evaluating the returned "Either" value
+    -- The Left value contains an (error "...") call
+    let invalidEntryHandler :: ErrorCall -> IO Bool
+        -- Assume invalid entry as Blob
+        invalidEntryHandler = \_ -> return False
+    isTree <- handle invalidEntryHandler $ do
+      mtype <- getObjectType git ref
+      case mtype of
+         Just TypeTree -> return True
+         _             -> return False
+    -- Return entry
+    return (perm, ObjId ref, name, isTree)
+
 viewPath :: Git SHA1 -> Tree SHA1 -> EntPath -> IO PathView
 viewPath git root path = do
     let toEnt False = EntObjBlob
@@ -136,7 +155,7 @@ viewPath git root path = do
         toText = decodeUtf8With lenientDecode . getEntNameBytes
         adapt (perm, oid, name, isTree) =
             (perm, oid, toText name, toEnt isTree)
-        mkRows t = map adapt <$> viewTree git t
+        mkRows t = map adapt <$> viewTree' git t -- FIXME
     mno <- resolveTreePath git root path
     case mno of
         Nothing          -> RootView <$> mkRows root

src/Vervis/Foundation.hs

@@ -911,6 +911,7 @@ instance YesodBreadcrumbs App where
         RepoSourceR r dir         -> (last dir, Just $ RepoSourceR r $ init dir)
         RepoBranchSourceR r b []  -> ("Branch " <> b <> " Files", Just $ RepoR r)
         RepoBranchSourceR r b dir -> (last dir, Just $ RepoBranchSourceR r b $ init dir)
+        RepoBranchRawR r b dir    -> ("", Nothing)
         RepoCommitsR r            -> ("Commits", Just $ RepoR r)
         RepoBranchCommitsR r b    -> ("Branch " <> b <> " Commits", Just $ RepoR r)
         RepoCommitR r c           -> (c, Just $ RepoCommitsR r)

src/Vervis/Git.hs

@@ -16,6 +16,7 @@
 
 module Vervis.Git
     ( readSourceView
+    , readRawView
     , readChangesView
     , listRefs
     , readPatch
@@ -175,6 +176,24 @@ readSourceView path ref dir = do
     let toTexts = S.mapMonotonic $ T.pack . refNameRaw
     return (toTexts bs, toTexts ts, renderSources dir <$> msv)
 
+readRawView
+    :: FilePath
+    -- ^ Repository path
+    -> Text
+    -- ^ Name of branch or tag
+    -> [Text]
+    -- ^ Path in the source tree pointing to a file or directory
+    -> IO (Maybe BL.ByteString)
+    -- ^ Raw content of the file
+readRawView path ref dir = do
+    (_, _, msv) <-
+        G.withRepo (fromString path) $ \ git -> loadSourceView git ref dir
+    case msv of
+        -- Returns the content of the regular file
+        Just (SourceFile (FileView _ body)) -> return $ Just body
+        -- Returns Nothing o.w. including root and directory
+        _ -> return Nothing
+
 readChangesView
     :: FilePath
     -- ^ Repository path

src/Vervis/Handler/Repo.hs

@@ -28,6 +28,7 @@ module Vervis.Handler.Repo
 
     , getRepoSourceR
     , getRepoBranchSourceR
+    , getRepoBranchRawR
     , getRepoCommitsR
     , getRepoBranchCommitsR
     , getRepoCommitR
@@ -402,6 +403,14 @@ getRepoBranchSourceR repoHash branch path = do
         VCSDarcs -> notFound
         VCSGit -> getGitRepoSource repo actor repoHash branch path looms
 
+getRepoBranchRawR :: KeyHashid Repo -> Text -> [Text] -> Handler TypedContent
+getRepoBranchRawR repoHash branch path = do
+    repoID <- decodeKeyHashid404 repoHash
+    repo <- runDB $ get404 repoID
+    case repoVcs repo of
+        VCSDarcs -> notFound
+        VCSGit -> getGitRepoRaw repoHash branch path
+
 getRepoCommitsR :: KeyHashid Repo -> Handler TypedContent
 getRepoCommitsR repoHash = do
     repoID <- decodeKeyHashid404 repoHash

src/Vervis/Web/Git.hs

@@ -16,6 +16,7 @@
 
 module Vervis.Web.Git
     ( getGitRepoSource
+    , getGitRepoRaw
     --, getGitRepoBranch
     , getGitRepoChanges
     , getGitPatch
@@ -123,6 +124,17 @@ getGitRepoSource repository actor repo ref dir loomIDs = do
     followButton =
         followW (RepoFollowR repo) (RepoUnfollowR repo) (actorFollowers actor)
 
+getGitRepoRaw
+    :: KeyHashid Repo -> Text -> [Text] -> Handler TypedContent
+getGitRepoRaw repo ref dir = do
+    path <- askRepoDir repo
+    msv <- liftIO $ G.readRawView path ref dir
+    case msv of
+        Nothing -> notFound
+        Just body -> return $
+            TypedContent typePlain $ -- TODO correct MIME type
+            toContent body
+
 {-
 getGitRepoBranch :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
 getGitRepoBranch shar repo ref = do

templates/repo/source-git.hamlet

@@ -87,7 +87,7 @@ $if not $ null looms
 
 $case sv
   $of SourceFile (FileView name body)
-    <h2>#{name}
+    <h2>#{name} <a href=@{RepoBranchRawR repo ref dir}>[Raw]</a>
     ^{body}
   $of SourceDir (DirectoryView mname ents mreadme)
     <h2>#{fromMaybe "Files" mname}

th/routes

@@ -193,6 +193,7 @@
 
 /repos/#RepoKeyHashid/source/+Texts               RepoSourceR        GET
 /repos/#RepoKeyHashid/source-by/#Text/+Texts      RepoBranchSourceR  GET
+/repos/#RepoKeyHashid/raw/#Text/+Texts            RepoBranchRawR     GET
 /repos/#RepoKeyHashid/commits                     RepoCommitsR       GET
 /repos/#RepoKeyHashid/commits-by/#Text            RepoBranchCommitsR GET
 /repos/#RepoKeyHashid/commits/#Text               RepoCommitR        GET