@@ -26,8 +26,9 @@ 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 (for_, toList)
29+import Data.Foldable (toList)
3030import Data.Function ((&))
31+import Data.Functor ((<&>))
3132import Data.Git.Ref (Ref)
3233import qualified Data.Git.Ref as Ref
3334import qualified Data.List as L
@@ -237,38 +238,35 @@ matchThunkSpecToDir
237238 -> Set FilePath -- ^ Set of file paths relative to the given directory
238239 -> m ThunkData
239240matchThunkSpecToDir thunkSpec dir dirFiles = do
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
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)
272270 where
273271 rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys
274272 takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath
@@ -284,6 +282,15 @@ matchThunkSpecToDir thunkSpec dir dirFiles = do
284282 True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
285283 False -> pure ()
286284
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+
287294 fold1WithM (x :| xs) f = foldM f x xs
288295
289296readThunkWith
@@ -298,7 +305,8 @@ readThunkWith specTypes dir = do
298305 Left e -> putLog Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${e}|] *> loop rest
299306 x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|]
300307
301−-- | Read a packed or unpacked thunk based on predefined thunk specifications.
308+-- | Read a thunk and validate that it is exactly a packed thunk.
309+-- If additional data is present, fail.
302310readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
303311readThunk = readThunkWith thunkSpecTypes
304312