From 284b4a8d81e72cdca718e21440bd8fc07b3ea498 Mon Sep 17 00:00:00 2001
From: sup39 <dev@sup39.dev>
Date: Thu, 11 Jan 2024 00:14:38 +0900
Subject: [PATCH] fix: prevent panic on parse error in repo page

---
 src/Data/Git/Local.hs | 21 ++++++++++++++++++++-
 1 file changed, 20 insertions(+), 1 deletion(-)

diff --git a/src/Data/Git/Local.hs b/src/Data/Git/Local.hs
index 8c809db..c5ef8da 100644
--- a/src/Data/Git/Local.hs
+++ b/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