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:
parent
8c7ed627b6
commit
284b4a8d81
1 changed files with 20 additions and 1 deletions
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue