1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 00:54:52 +09:00

fix: prevent panic on parse error in repo page

This commit is contained in:
sup39 2024-01-11 00:14:38 +09:00
parent 8c7ed627b6
commit 284b4a8d81
Signed by: sup39
GPG key ID: 111C00916C1641E5

View file

@ -50,6 +50,9 @@ import qualified Data.Text.IO as TIO
import Data.EventTime.Local import Data.EventTime.Local
import Data.Hourglass.Local () import Data.Hourglass.Local ()
import Data.Traversable (for)
import Data.Git.Storage (getObjectType)
instance SpecToEventTime GitTime where instance SpecToEventTime GitTime where
specToEventTime = specToEventTime . gitTimeUTC specToEventTime = specToEventTime . gitTimeUTC
specsToEventTimes = specsToEventTimes . fmap gitTimeUTC specsToEventTimes = specsToEventTimes . fmap gitTimeUTC
@ -129,6 +132,22 @@ data PathView
| TreeView Text ObjId TreeRows | TreeView Text ObjId TreeRows
| BlobView Text ObjId BL.ByteString | 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 SHA1 -> Tree SHA1 -> EntPath -> IO PathView
viewPath git root path = do viewPath git root path = do
let toEnt False = EntObjBlob let toEnt False = EntObjBlob
@ -136,7 +155,7 @@ viewPath git root path = do
toText = decodeUtf8With lenientDecode . getEntNameBytes toText = decodeUtf8With lenientDecode . getEntNameBytes
adapt (perm, oid, name, isTree) = adapt (perm, oid, name, isTree) =
(perm, oid, toText name, toEnt 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 mno <- resolveTreePath git root path
case mno of case mno of
Nothing -> RootView <$> mkRows root Nothing -> RootView <$> mkRows root