Heavy lifting

This refactors the store to make it composable with arbitrary mtl monad
stacks, with the added constraint that `addToStore` takes a filtering
fucntion `FilePath -> PathFilter -> m Bool` which is not
MonadBaseControl compatible, and cannot be lifted (the monad is in a
negative/contravariant position).

The solution involves a RemoteStoreT transformer, a MonadRemoteStore
monad and still lacks a proper generic MonadStore which I would like to
make generic across all the store implementations (in-memeory /
read-only / remote daemon / etc.)

Author: layus

hnix-store-core/src/System/Nix/Internal/Nar/Effects.hs

@@ -5,6 +5,7 @@
 
 module System.Nix.Internal.Nar.Effects
   ( NarEffects(..)
+  , PathType(..)
   , narEffectsIO
   ) where
 
@@ -18,9 +19,16 @@ import           Data.Int                    (Int64)
 import qualified System.Directory            as Directory
 import qualified System.Directory            as Directory
 import qualified System.IO                   as IO
-import           System.Posix.Files          (createSymbolicLink, fileSize,
-                                              getFileStatus, isDirectory,
-                                              readSymbolicLink)
+import           System.Posix.Files          (createSymbolicLink, fileSize, readSymbolicLink,
+                                              getFileStatus, isRegularFile, isDirectory, isSymbolicLink)
+
+data PathType = Regular | Directory | Symlink | Unknown deriving Show
+
+pathTypeFromPosix status
+  | isRegularFile  status = Regular
+  | isDirectory    status = Directory
+  | isSymbolicLink status = Symlink
+  | otherwise             = Unknown
 
 data NarEffects (m :: * -> *) = NarEffects {
     narReadFile   :: FilePath -> m BSL.ByteString
@@ -31,8 +39,7 @@ data NarEffects (m :: * -> *) = NarEffects {
   , narCreateLink :: FilePath -> FilePath -> m ()
   , narGetPerms   :: FilePath -> m Directory.Permissions
   , narSetPerms   :: FilePath -> Directory.Permissions ->  m ()
-  , narIsDir      :: FilePath -> m Bool
-  , narIsSymLink  :: FilePath -> m Bool
+  , narPathType   :: FilePath -> m PathType
   , narFileSize   :: FilePath -> m Int64
   , narReadLink   :: FilePath -> m FilePath
   , narDeleteDir  :: FilePath -> m ()
@@ -57,8 +64,7 @@ narEffectsIO = NarEffects {
   , narCreateLink = \f t -> IO.liftIO $ createSymbolicLink f t
   , narGetPerms   = IO.liftIO . Directory.getPermissions
   , narSetPerms   = \f p -> IO.liftIO $ Directory.setPermissions f p
-  , narIsDir      = \d -> fmap isDirectory $ IO.liftIO (getFileStatus d)
-  , narIsSymLink  = IO.liftIO . Directory.pathIsSymbolicLink
+  , narPathType   = \f -> fmap pathTypeFromPosix $ IO.liftIO (getFileStatus f)
   , narFileSize   = \n -> fmap (fromIntegral . fileSize) $ IO.liftIO (getFileStatus n)
   , narReadLink   = IO.liftIO . readSymbolicLink
   , narDeleteDir  = IO.liftIO . Directory.removeDirectoryRecursive

hnix-store-core/src/System/Nix/Internal/Nar/Parser.hs

@@ -91,10 +91,10 @@ runParser effs (NarParser action) h target = do
 
     cleanup :: m ()
     cleanup = do
-      isDir <- Nar.narIsDir effs target
-      if isDir
-        then Nar.narDeleteDir  effs target
-        else Nar.narDeleteFile effs target
+      pathType <- Nar.narPathType effs target
+      case pathType of
+        Nar.Directory -> Nar.narDeleteDir  effs target
+        _             -> Nar.narDeleteFile effs target
 
 
 instance Trans.MonadTrans NarParser where

hnix-store-core/src/System/Nix/Internal/Nar/Streamer.hs

@@ -28,26 +28,24 @@ import qualified System.Nix.Internal.Nar.Effects as Nar
 streamNarIO
   :: forall m.(IO.MonadIO m)
   => (BS.ByteString -> m ())
+  -> (FilePath -> Nar.PathType -> m Bool)
   -> Nar.NarEffects IO
   -> FilePath
   -> m ()
-streamNarIO yield effs basePath = do
+streamNarIO yield filter effs basePath = do
   yield (str "nix-archive-1")
-  parens (go basePath)
+  basePathType <- IO.liftIO $ Nar.narPathType effs basePath
+  parens (go basePath basePathType)
   where
 
-    go :: FilePath -> m ()
-    go path = do
-      isDir     <- IO.liftIO $ Nar.narIsDir effs path
-      isSymLink <- IO.liftIO $ Nar.narIsSymLink effs path
-      let isRegular = not (isDir || isSymLink)
-
-      when isSymLink $ do
+    go :: FilePath -> Nar.PathType -> m ()
+    go path = \case of
+      Nar.Symlink -> do
         target <- IO.liftIO $ Nar.narReadLink effs path
         yield $
           strs ["type", "symlink", "target", BSC.pack target]
 
-      when isRegular $ do
+      Nar.Regular -> do
         isExec <- IO.liftIO $ isExecutable effs path
         yield $ strs ["type","regular"]
         when (isExec == Executable) (yield $ strs ["executable", ""])
@@ -56,15 +54,21 @@ streamNarIO yield effs basePath = do
         yield $ int fSize
         yieldFile path fSize
 
-      when isDir $ do
+      Nar.Directory -> do
         fs <- IO.liftIO (Nar.narListDir effs path)
         yield $ strs ["type", "directory"]
         forM_ (List.sort fs) $ \f -> do
-          yield $ str "entry"
-          parens $ do
-            let fullName = path </> f
-            yield (strs ["name", BSC.pack f, "node"])
-            parens (go fullName)
+          let fullName = path </> f
+          pathType <- IO.liftIO $ Nar.narPathType effs fullName
+          keep <- filter fullName pathType
+          when keep $ do
+            yield $ str "entry"
+            parens $ do
+              yield (strs ["name", BSC.pack f, "node"])
+              parens (go fullName pathType)
+
+      Nar.Unknown -> do
+        IO.liftIO $ fail $ "Cannot serialise path " ++ path
 
     str :: BS.ByteString -> BS.ByteString
     str t = let len =  BS.length t

hnix-store-core/src/System/Nix/Nar.hs

@@ -18,6 +18,7 @@ module System.Nix.Nar (
   -- * Encoding and Decoding NAR archives
     buildNarIO
   , unpackNarIO
+  , Nar.PathType (..)
 
   -- * Experimental
   , Nar.parseNar
@@ -67,7 +68,7 @@ buildNarIO
   -> IO.Handle
   -> IO ()
 buildNarIO effs basePath outHandle = do
-  Nar.streamNarIO (\chunk -> BS.hPut outHandle chunk >> Concurrent.threadDelay 10) effs basePath
+  Nar.streamNarIO (\chunk -> BS.hPut outHandle chunk >> Concurrent.threadDelay 10) (\p pt -> pure True) effs basePath
 
 
 -- | Read NAR formatted bytes from the @IO.Handle@ and unpack them into

hnix-store-remote/src/System/Nix/Store/Remote.hs

@@ -9,8 +9,8 @@
 {-# LANGUAGE RecordWildCards     #-}
 module System.Nix.Store.Remote
   (
-    MonadStoreT
-  , MonadStore
+    RemoteStoreT
+  , System.Nix.Nar.PathType (..)
   , addToStore
   , addTextToStore
   , addSignatures
@@ -75,14 +75,14 @@ type CheckSigsFlag = Bool
 type SubstituteFlag = Bool
 
 -- | Pack `FilePath` as `Nar` and add it to the store.
-addToStore :: forall a m. (ValidAlgo a, NamedAlgo a, MonadIO m)
+addToStore :: forall a m. (NamedAlgo a, MonadRemoteStore m, MonadIO m)
            => StorePathName        -- ^ Name part of the newly created `StorePath`
            -> FilePath             -- ^ Local `FilePath` to add
            -> Bool                 -- ^ Add target directory recursively
-           -> (FilePath -> Bool)   -- ^ Path filter function
+           -> (FilePath -> System.Nix.Nar.PathType -> m Bool)   -- ^ Path filter function
            -> RepairFlag           -- ^ Only used by local store backend
-           -> MonadStoreT m StorePath
-addToStore name pth recursive _pathFilter _repair = do
+           -> m StorePath
+addToStore name pth recursive pathFilter _repair = do
 
   runOpArgsIO AddToStore $ \yield -> do
     yield $ Data.ByteString.Lazy.toStrict $ Data.Binary.Put.runPut $ do
@@ -96,20 +96,20 @@ addToStore name pth recursive _pathFilter _repair = do
 
       putText $ System.Nix.Hash.algoName @a
 
-    System.Nix.Nar.streamNarIO yield System.Nix.Nar.narEffectsIO pth
+    System.Nix.Nar.streamNarIO yield pathFilter System.Nix.Nar.narEffectsIO pth
 
   sockGetPath
 
 -- | Add text to store.
 --
 -- Reference accepts repair but only uses it
 -- to throw error in case of remote talking to nix-daemon.
-addTextToStore :: (MonadIO m)
+addTextToStore :: (MonadIO m, MonadRemoteStore m)
                => Text         -- ^ Name of the text
                -> Text         -- ^ Actual text to add
                -> StorePathSet -- ^ Set of `StorePath`s that the added text references
                -> RepairFlag   -- ^ Repair flag, must be `False` in case of remote backend
-               -> MonadStoreT m StorePath
+               -> m StorePath
 addTextToStore name text references' repair = do
   when repair $ error "repairing is not supported when building through the Nix daemon"
   runOpArgs AddTextToStore $ do
@@ -118,40 +118,43 @@ addTextToStore name text references' repair = do
     putPaths references'
   sockGetPath
 
-addSignatures :: StorePath
+addSignatures :: (MonadIO m)
+              => StorePath
               -> [ByteString]
-              -> MonadStore ()
+              -> RemoteStoreT m ()
 addSignatures p signatures = do
   void $ simpleOpArgs AddSignatures $ do
     putPath p
     putByteStrings signatures
 
-addIndirectRoot :: StorePath -> MonadStore ()
+addIndirectRoot :: (MonadIO m) => StorePath -> RemoteStoreT m ()
 addIndirectRoot pn = do
   void $ simpleOpArgs AddIndirectRoot $ putPath pn
 
 -- | Add temporary garbage collector root.
 --
 -- This root is removed as soon as the client exits.
-addTempRoot :: StorePath -> MonadStore ()
+addTempRoot :: (MonadIO m) => StorePath -> RemoteStoreT m ()
 addTempRoot pn = do
   void $ simpleOpArgs AddTempRoot $ putPath pn
 
 -- | Build paths if they are an actual derivations.
 --
 -- If derivation output paths are already valid, do nothing.
-buildPaths :: StorePathSet
+buildPaths :: (MonadIO m)
+           => StorePathSet
            -> BuildMode
-           -> MonadStore ()
+           -> RemoteStoreT m ()
 buildPaths ps bm = do
   void $ simpleOpArgs BuildPaths $ do
     putPaths ps
     putInt $ fromEnum bm
 
-buildDerivation :: StorePath
+buildDerivation :: (MonadIO m)
+                => StorePath
                 -> Derivation StorePath Text
                 -> BuildMode
-                -> MonadStore BuildResult
+                -> RemoteStoreT m BuildResult
 buildDerivation p drv buildMode = do
   runOpArgs BuildDerivation $ do
     putPath p
@@ -165,12 +168,12 @@ buildDerivation p drv buildMode = do
   res <- getSocketIncremental $ getBuildResult
   return res
 
-ensurePath :: StorePath -> MonadStore ()
+ensurePath :: (MonadIO m) => StorePath -> RemoteStoreT m ()
 ensurePath pn = do
   void $ simpleOpArgs EnsurePath $ putPath pn
 
 -- | Find garbage collector roots.
-findRoots :: MonadStore (Map ByteString StorePath)
+findRoots :: (MonadIO m) => RemoteStoreT m (Map ByteString StorePath)
 findRoots = do
   runOp FindRoots
   sd <- getStoreDir
@@ -182,40 +185,42 @@ findRoots = do
   r <- catRights res
   return $ Data.Map.Strict.fromList r
   where
-    catRights :: [(a, Either String b)] -> MonadStore [(a, b)]
+    catRights :: (MonadIO m) => [(a, Either String b)] -> RemoteStoreT m [(a, b)]
     catRights = mapM ex
 
-    ex :: (a, Either [Char] b) -> MonadStore (a, b)
+    ex :: (MonadIO m) => (a, Either [Char] b) -> RemoteStoreT m (a, b)
     ex (x, Right y) = return (x, y)
     ex (_x , Left e) = error $ "Unable to decode root: "  ++ e
 
-isValidPathUncached :: StorePath -> MonadStore Bool
+isValidPathUncached :: (MonadIO m) => StorePath -> RemoteStoreT m Bool
 isValidPathUncached p = do
   simpleOpArgs IsValidPath $ putPath p
 
 -- | Query valid paths from set, optionally try to use substitutes.
-queryValidPaths :: StorePathSet   -- ^ Set of `StorePath`s to query
+queryValidPaths :: (MonadIO m)
+                => StorePathSet   -- ^ Set of `StorePath`s to query
                 -> SubstituteFlag -- ^ Try substituting missing paths when `True`
-                -> MonadStore StorePathSet
+                -> RemoteStoreT m StorePathSet
 queryValidPaths ps substitute = do
   runOpArgs QueryValidPaths $ do
     putPaths ps
     putBool substitute
   sockGetPaths
 
-queryAllValidPaths :: MonadStore StorePathSet
+queryAllValidPaths :: (MonadIO m) => RemoteStoreT m StorePathSet
 queryAllValidPaths = do
   runOp QueryAllValidPaths
   sockGetPaths
 
-querySubstitutablePaths :: StorePathSet -> MonadStore StorePathSet
+querySubstitutablePaths :: (MonadIO m) => StorePathSet -> RemoteStoreT m StorePathSet
 querySubstitutablePaths ps = do
   runOpArgs QuerySubstitutablePaths $ do
     putPaths ps
   sockGetPaths
 
-queryPathInfoUncached :: StorePath
-                      -> MonadStore StorePathMetadata
+queryPathInfoUncached :: (MonadIO m)
+                      => StorePath
+                      -> RemoteStoreT m StorePathMetadata
 queryPathInfoUncached path = do
   runOpArgs QueryPathInfo $ do
     putPath path
@@ -252,31 +257,31 @@ queryPathInfoUncached path = do
 
   return $ StorePathMetadata {..}
 
-queryReferrers :: StorePath -> MonadStore StorePathSet
+queryReferrers :: (MonadIO m) => StorePath -> RemoteStoreT m StorePathSet
 queryReferrers p = do
   runOpArgs QueryReferrers $ do
     putPath p
   sockGetPaths
 
-queryValidDerivers :: StorePath -> MonadStore StorePathSet
+queryValidDerivers :: (MonadIO m) => StorePath -> RemoteStoreT m StorePathSet
 queryValidDerivers p = do
   runOpArgs QueryValidDerivers $ do
     putPath p
   sockGetPaths
 
-queryDerivationOutputs :: StorePath -> MonadStore StorePathSet
+queryDerivationOutputs :: (MonadIO m) => StorePath -> RemoteStoreT m StorePathSet
 queryDerivationOutputs p = do
   runOpArgs QueryDerivationOutputs $
     putPath p
   sockGetPaths
 
-queryDerivationOutputNames :: StorePath -> MonadStore StorePathSet
+queryDerivationOutputNames :: (MonadIO m) => StorePath -> RemoteStoreT m StorePathSet
 queryDerivationOutputNames p = do
   runOpArgs QueryDerivationOutputNames $
     putPath p
   sockGetPaths
 
-queryPathFromHashPart :: Digest StorePathHashAlgo -> MonadStore StorePath
+queryPathFromHashPart :: (MonadIO m) => Digest StorePathHashAlgo -> RemoteStoreT m StorePath
 queryPathFromHashPart storePathHash = do
   runOpArgs QueryPathFromHashPart $
     putByteStringLen
@@ -285,12 +290,13 @@ queryPathFromHashPart storePathHash = do
       $ System.Nix.Hash.encodeBase32 storePathHash
   sockGetPath
 
-queryMissing :: StorePathSet
-             -> MonadStore ( StorePathSet -- Paths that will be built
-                           , StorePathSet -- Paths that have substitutes
-                           , StorePathSet -- Unknown paths
-                           , Integer      -- Download size
-                           , Integer)     -- Nar size?
+queryMissing :: (MonadIO m)
+             => StorePathSet
+             -> RemoteStoreT m ( StorePathSet -- Paths that will be built
+                              , StorePathSet -- Paths that have substitutes
+                              , StorePathSet -- Unknown paths
+                              , Integer      -- Download size
+                              , Integer)     -- Nar size?
 queryMissing ps = do
   runOpArgs QueryMissing $ do
     putPaths ps
@@ -302,14 +308,14 @@ queryMissing ps = do
   narSize'       <- sockGetInt
   return (willBuild, willSubstitute, unknown, downloadSize', narSize')
 
-optimiseStore :: MonadStore ()
+optimiseStore :: (MonadIO m) => RemoteStoreT m ()
 optimiseStore = void $ simpleOp OptimiseStore
 
-syncWithGC :: MonadStore ()
+syncWithGC :: (MonadIO m) => RemoteStoreT m ()
 syncWithGC = void $ simpleOp SyncWithGC
 
 -- returns True on errors
-verifyStore :: CheckFlag -> RepairFlag -> MonadStore Bool
+verifyStore :: (MonadIO m) => CheckFlag -> RepairFlag -> RemoteStoreT m Bool
 verifyStore check repair = simpleOpArgs VerifyStore $ do
   putBool check
   putBool repair