WIP: Lift the monad stack to a monad stack transformer

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(..))
 
 
 

hnix-store-remote/hnix-store-remote.cabal

@@ -30,22 +30,22 @@ library
                      , System.Nix.Store.Remote.Types
                      , System.Nix.Store.Remote.Util
 
-  build-depends:       base >=4.10 && <5
-                     , attoparsec
-                     , bytestring
+  build-depends:       attoparsec
+                     , base >=4.10 && <5
                      , binary
                      , bytestring
                      , containers
                      , filepath
-                     , text
-                     , unix
+                     , hnix-store-core
+                     , lifted-base
+                     , monad-control
+                     , mtl
                      , network
                      , nix-derivation >= 1.1.1 && <2
-                     , mtl
-                     , unordered-containers
-                     , filepath
+                     , text
                      , time
-                     , hnix-store-core
+                     , unix
+                     , unordered-containers
                      , vector
   hs-source-dirs:      src
   default-language:    Haskell2010
@@ -55,13 +55,13 @@ test-suite hnix-store-remote-tests
    if !flag(io-testsuite)
      buildable: False
 
-   build-tool-depends: nix:nix-daemon
-
    ghc-options:       -rtsopts -fprof-auto
    type:              exitcode-stdio-1.0
    main-is:           Driver.hs
    other-modules:     Derivation
                     , NixDaemon
+                    , Spec
+                    , Util
    hs-source-dirs:    tests
    build-depends:
                        attoparsec
@@ -76,6 +76,7 @@ test-suite hnix-store-remote-tests
                      , process
                      , filepath
                      , hspec-expectations-lifted
+                     , quickcheck-text
                      , tasty
                      , tasty-discover
                      , tasty-hspec