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,
+                                              getSymbolicLinkStatus, 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,9 +64,8 @@ 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
-  , narFileSize   = \n -> fmap (fromIntegral . fileSize) $ IO.liftIO (getFileStatus n)
+  , narPathType   = \f -> fmap pathTypeFromPosix $ IO.liftIO (getSymbolicLinkStatus f)
+  , narFileSize   = \n -> fmap (fromIntegral . fileSize) $ IO.liftIO (getSymbolicLinkStatus n)
   , narReadLink   = IO.liftIO . readSymbolicLink
   , narDeleteDir  = IO.liftIO . Directory.removeDirectoryRecursive
   , narDeleteFile = IO.liftIO . Directory.removeFile

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE LambdaCase          #-}
 
 module System.Nix.Internal.Nar.Streamer where
 
@@ -28,26 +29,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
+      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 +55,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-core/tests/NarFormat.hs

@@ -54,7 +54,7 @@ import qualified Text.Printf                      as Printf
 import           Text.Read                        (readMaybe)
 
 import qualified System.Nix.Internal.Nar.Streamer as Nar
-import           System.Nix.Nar
+import           System.Nix.Nar                   hiding (PathType(..))