@@ -26,9 +26,8 @@ import qualified Data.ByteString.Lazy as LBS
2626import Data.Containers.ListUtils (nubOrd)
2727import Data.Default
2828import Data.Either.Combinators (fromRight', rightToMaybe)
29−import Data.Foldable (toList)
29+import Data.Foldable (for_, toList)
3030import Data.Function ((&))
31−import Data.Functor ((<&>))
3231import Data.Git.Ref (Ref)
3332import qualified Data.Git.Ref as Ref
3433import qualified Data.List as L
@@ -238,35 +237,38 @@ matchThunkSpecToDir
238237 -> Set FilePath -- ^ Set of file paths relative to the given directory
239238 -> m ThunkData
240239matchThunkSpecToDir thunkSpec dir dirFiles = do
241− case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
242− Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
243− Nothing -> pure ()
244− case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
245− Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
246− Nothing -> pure ()
247− datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
248− ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
249− ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case
250− False -> Nothing
251− True -> Just ThunkData_Checkout
252− ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
253− actualContents <- liftIO (T.readFile $ dir </> expectedPath)
254− case T.strip expectedContents == T.strip actualContents of
255− True -> pure Nothing
256− False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
257− ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
258− let path = dir </> expectedPath
259− liftIO (doesFileExist path) >>= \case
260− False -> pure Nothing
261− True -> do
262− actualContents <- liftIO $ LBS.readFile path
263− case parser actualContents of
264− Right v -> pure $ Just (ThunkData_Packed thunkSpec v)
265− Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
266−
267− case nonEmpty datas of
268− Nothing -> throwError ReadThunkError_UnrecognizedThunk
269− Just xs -> fold1WithM xs $ \a b -> either throwError pure (mergeThunkData a b)
240+ isCheckout <- fmap or $ flip Map.traverseWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
241+ ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath))
242+ _ -> pure False
243+ case isCheckout of
244+ True -> pure ThunkData_Checkout
245+ False -> do
246+ for_ (nonEmpty (toList $ dirFiles `Set.difference` expectedPaths)) $ \fs ->
247+ throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
248+ for_ (nonEmpty (toList $ requiredPaths `Set.difference` dirFiles)) $ \fs ->
249+ throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
250+ datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
251+ ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
252+ ThunkFileSpec_CheckoutIndicator -> pure Nothing -- Handled above
253+ ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
254+ actualContents <- liftIO (T.readFile $ dir </> expectedPath)
255+ case T.strip expectedContents == T.strip actualContents of
256+ True -> pure Nothing
257+ False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
258+ ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
259+ let path = dir </> expectedPath
260+ liftIO (doesFileExist path) >>= \case
261+ False -> pure Nothing
262+ True -> do
263+ actualContents <- liftIO $ LBS.readFile path
264+ case parser actualContents of
265+ Right v -> pure $ Just (thunkSpec, v)
266+ Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
267+
268+ uncurry ThunkData_Packed <$> case nonEmpty datas of
269+ Nothing -> throwError ReadThunkError_UnrecognizedThunk
270+ Just xs -> fold1WithM xs $ \a@(_, ptrA) (_, ptrB) ->
271+ if ptrA == ptrB then pure a else throwError $ ReadThunkError_AmbiguousPackedState ptrA ptrB
270272 where
271273 rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys
272274 takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath
@@ -282,15 +284,6 @@ matchThunkSpecToDir thunkSpec dir dirFiles = do
282284 True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
283285 False -> pure ()
284286
285− -- Combine 'ThunkData' from different files, preferring "Checkout" over "Packed"
286− mergeThunkData ThunkData_Checkout ThunkData_Checkout = Right ThunkData_Checkout
287− mergeThunkData ThunkData_Checkout ThunkData_Packed{} = Left bothPackedAndUnpacked
288− mergeThunkData ThunkData_Packed{} ThunkData_Checkout = Left bothPackedAndUnpacked
289− mergeThunkData a@(ThunkData_Packed _ ptrA) (ThunkData_Packed _ ptrB) =
290− if ptrA == ptrB then Right a else Left $ ReadThunkError_AmbiguousPackedState ptrA ptrB
291−
292− bothPackedAndUnpacked = ReadThunkError_UnrecognizedState "Both packed data and checkout present"
293−
294287 fold1WithM (x :| xs) f = foldM f x xs
295288
296289readThunkWith
@@ -305,8 +298,7 @@ readThunkWith specTypes dir = do
305298 Left e -> putLog Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${e}|] *> loop rest
306299 x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|]
307300
308−-- | Read a thunk and validate that it is exactly a packed thunk.
309−-- If additional data is present, fail.
301+-- | Read a packed or unpacked thunk based on predefined thunk specifications.
310302readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
311303readThunk = readThunkWith thunkSpecTypes
312304