Implement 'addToStore'

hnix-store-core/src/System/Nix/Internal/StorePath.hs

@@ -49,6 +49,9 @@ data StorePath (storeDir :: StoreDir) = StorePath
     storePathName :: !StorePathName
   } deriving (Eq, Ord)
 
+instance forall storeDir. KnownStoreDir storeDir => Show (StorePath storeDir) where
+  show = show . storePathToRawFilePath
+
 instance Hashable (StorePath storeDir) where
   hashWithSalt s (StorePath {..}) =
     s `hashWithSalt` storePathHash `hashWithSalt` storePathName

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

@@ -15,6 +15,8 @@ module System.Nix.Nar (
   , Nar(..)
   , getNar
   , localPackNar
+  , localPackNar'
+  , FilePathFilter
   , localUnpackNar
   , narEffectsIO
   , putNar
@@ -240,10 +242,15 @@ localUnpackNar effs basePath (Nar fso) = localUnpackFSO basePath fso
 
 -- | Pack a NAR from a filepath
 localPackNar :: Monad m => NarEffects m -> FilePath -> m Nar
-localPackNar effs basePath = Nar <$> localPackFSO basePath
+localPackNar effs basePath = localPackNar' effs basePath (const True)
 
-  where
+type FilePathFilter = FilePath -> Bool
+
+-- | Pack a NAR from a filepath, omitting the entries matching `filter`
+localPackNar' :: Monad m => NarEffects m -> FilePath -> FilePathFilter -> m Nar
+localPackNar' effs basePath pathFilter = Nar <$> localPackFSO basePath
 
+  where
     localPackFSO path' = do
       fType <- (,) <$> narIsDir effs path' <*> narIsSymLink effs path'
       case fType of
@@ -252,7 +259,7 @@ localPackNar effs basePath = Nar <$> localPackFSO basePath
                               <*> narFileSize effs path'
                               <*> narReadFile effs path'
         (True , _) -> fmap (Directory . Map.fromList) $ do
-          fs <- narListDir effs path'
+          fs <- filter (pathFilter . (path' </>)) <$> narListDir effs path'
           forM fs $ \fp ->
             (FilePathPart (BSC.pack $  fp),) <$> localPackFSO (path' </> fp)
 

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

@@ -38,3 +38,35 @@ library
   hs-source-dirs:      src
   default-language:    Haskell2010
   ghc-options:         -Wall
+
+test-suite format-tests
+   ghc-options: -rtsopts -fprof-auto
+   type: exitcode-stdio-1.0
+   main-is: Driver.hs
+   other-modules:
+       Operations
+   hs-source-dirs:
+       tests
+   build-depends:
+       hnix-store-core
+     , hnix-store-remote
+     , base
+     , base64-bytestring
+     , binary
+     , bytestring
+     , containers
+     , directory
+     , filepath
+     , mtl
+     , network
+     , process
+     , text
+     , unix
+     , unordered-containers
+     , tasty
+     , tasty-discover
+     , tasty-hspec
+     , tasty-hunit
+     , tasty-quickcheck
+     , temporary
+   default-language: Haskell2010

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

@@ -5,30 +5,88 @@
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE ViewPatterns        #-}
+
 module System.Nix.Store.Remote (
     runStore
+  , addToStore
   , syncWithGC
   , optimiseStore
   , verifyStore
   ) where
 
+import           Prelude                 as P
 import           Control.Monad
+import           Control.Monad.Except
+
+import           Data.Text               as T
+import           Data.Text.Encoding      as T
+import           Data.Text.Lazy          as TL
+import           Data.Text.Lazy.Encoding as TL
 
+import           System.Nix.Hash
+import           System.Nix.Internal.Hash
+import           System.Nix.Nar
+import           System.Nix.StorePath
 import           System.Nix.Store.Remote.Types
 import           System.Nix.Store.Remote.Protocol
 import           System.Nix.Store.Remote.Util
+import           System.Nix.Util
+
+import           Data.ByteString.Lazy as LBS
+import           Data.ByteString.Char8 as BS
+
 
 type RepairFlag = Bool
 type CheckFlag = Bool
+type RecursiveFlag = Bool
 
-syncWithGC :: MonadStore ()
+syncWithGC :: MonadStore s ()
 syncWithGC = void $ simpleOp SyncWithGC
 
-optimiseStore :: MonadStore ()
+optimiseStore :: MonadStore s ()
 optimiseStore = void $ simpleOp OptimiseStore
 
 -- returns True on errors
-verifyStore :: CheckFlag -> RepairFlag -> MonadStore Bool
+verifyStore :: CheckFlag -> RepairFlag -> MonadStore s Bool
 verifyStore check repair = simpleOpArgs VerifyStore $ do
   putBool check
   putBool repair
+
+addToStore :: forall hashType storeDir. (NamedAlgo hashType, ValidAlgo hashType, KnownStoreDir storeDir)
+    => StorePathName
+    -> FilePath
+    -> RecursiveFlag
+    -> FilePathFilter
+    -> RepairFlag
+    -> MonadStore storeDir (StorePath storeDir)
+addToStore name srcPath recursive pathFilter repair = do
+  when repair $ throwError "addToStore: Cannot repair when using a daemon."
+  nar <- liftIO $ localPackNar' narEffectsIO srcPath pathFilter
+  runOpArgs AddToStore $ do
+    putByteStringLen $ strToN $ unStorePathName name
+    putBool $ not (recursive && algoName @hashType == "sha256") -- backward compatibility hack
+    putBool recursive
+    putByteStringLen $ strToN (algoName @hashType)
+    putNar nar
+
+  path <- LBS.toStrict <$> sockGetStr
+  case makeStorePath path of
+    Just storePath -> return storePath
+    Nothing -> throwError $ "Path '" ++ (show path) ++ "' is not a valid store path in this store"
+
+ where
+  strToN = TL.encodeUtf8 . TL.fromStrict
+
+  makeStorePath :: BS.ByteString -> Maybe (StorePath storeDir)
+  makeStorePath path = BS.stripPrefix (storeDirVal @storeDir <> "/") path >>= \basename ->
+    if '/' `BS.elem` basename
+    then Nothing
+    else let (drvHash, drvName) = BS.break (== '-') basename in
+      if BS.length drvHash /= 32 || BS.length drvName <= 1
+      then Nothing
+      else StorePath (Digest drvHash) <$> (makeStorePathName $ T.tail $ T.decodeUtf8 $ drvName)
+
+
+
+

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

@@ -26,10 +26,10 @@ controlParser = do
     0x52534c54 -> Result        <$> getInt <*> getInt <*> getFields
     x          -> fail           $ "Invalid control message received:" ++ show x
 
-processOutput :: MonadStore [Logger]
+processOutput :: MonadStore s [Logger]
 processOutput = go decoder
   where decoder = runGetIncremental controlParser
-        go :: Decoder Logger -> MonadStore [Logger]
+        go :: Decoder Logger -> MonadStore s [Logger]
         go (Done _leftover _consumed ctrl) = do
           case ctrl of
             e@(Error _ _) -> return [e]

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

@@ -107,11 +107,11 @@ opNum AddToStoreNar               = 39
 opNum QueryMissing                = 40
 
 
-simpleOp :: WorkerOp -> MonadStore Bool
+simpleOp :: WorkerOp -> MonadStore s Bool
 simpleOp op = do
   simpleOpArgs op $ return ()
 
-simpleOpArgs :: WorkerOp -> Put -> MonadStore Bool
+simpleOpArgs :: WorkerOp -> Put -> MonadStore s Bool
 simpleOpArgs op args = do
   runOpArgs op args
   err <- gotError
@@ -122,10 +122,10 @@ simpleOpArgs op args = do
     False -> do
       sockGetBool
 
-runOp :: WorkerOp -> MonadStore ()
+runOp :: WorkerOp -> MonadStore s ()
 runOp op = runOpArgs op $ return ()
 
-runOpArgs :: WorkerOp -> Put -> MonadStore ()
+runOpArgs :: WorkerOp -> Put -> MonadStore s ()
 runOpArgs op args = do
 
   -- Temporary hack for printing the messages destined for nix-daemon socket
@@ -145,7 +145,7 @@ runOpArgs op args = do
     Error _num msg <- head <$> getError
     throwError $ BSC.unpack $ LBS.toStrict msg
 
-runStore :: MonadStore a -> IO (Either String a, [Logger])
+runStore :: MonadStore s a -> IO (Either String a, [Logger])
 runStore code = do
   bracket (open sockPath) close run
   where

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

@@ -1,3 +1,7 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+
 module System.Nix.Store.Remote.Types (
     MonadStore
   , Logger(..)
@@ -8,13 +12,15 @@ module System.Nix.Store.Remote.Types (
   , getError) where
 
 
+import           System.Nix.Internal.StorePath
 import qualified Data.ByteString.Lazy      as LBS
 import           Network.Socket            (Socket)
 import           Control.Monad.Except
 import           Control.Monad.Reader
 import           Control.Monad.State
 
-type MonadStore a = ExceptT String (StateT [Logger] (ReaderT Socket IO)) a
+type MonadStore (storeDir :: StoreDir) a = ExceptT String (StateT [Logger] (ReaderT Socket IO)) a
+-- type AMonadStore s a = forall storeDir. MonadStore storeDir a
 
 type ActivityID = Int
 type ActivityParentID = Int
@@ -40,14 +46,14 @@ isError :: Logger -> Bool
 isError (Error _ _) = True
 isError _           = False
 
-gotError :: MonadStore Bool
+gotError :: MonadStore s Bool
 gotError = any isError <$> get
 
-getError :: MonadStore [Logger]
+getError :: MonadStore s [Logger]
 getError = filter isError <$> get
 
-getLog :: MonadStore [Logger]
+getLog :: MonadStore s [Logger]
 getLog = get
 
-flushLog :: MonadStore ()
+flushLog :: MonadStore s ()
 flushLog = put []

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

@@ -30,29 +30,29 @@ genericIncremental getsome parser = go decoder
         go (Fail _leftover _consumed msg) = do
           error msg
 
-getSocketIncremental :: Get a -> MonadStore a
+getSocketIncremental :: Get a -> MonadStore s a
 getSocketIncremental = genericIncremental sockGet
 
-sockPut :: Put -> MonadStore ()
+sockPut :: Put -> MonadStore s ()
 sockPut p = do
   soc <- ask
   liftIO $ sendAll soc $ LBS.toStrict $ runPut p
 
-sockGet :: MonadStore (Maybe BSC.ByteString)
+sockGet :: MonadStore s (Maybe BSC.ByteString)
 sockGet = do
   soc <- ask
   liftIO $ Just <$> recv soc 8
 
-sockGetInt :: Integral a => MonadStore a
+sockGetInt :: Integral a => MonadStore s a
 sockGetInt = getSocketIncremental getInt
 
-sockGetBool :: MonadStore Bool
+sockGetBool :: MonadStore s Bool
 sockGetBool = (== (1 :: Int)) <$> sockGetInt
 
-sockGetStr :: MonadStore LBS.ByteString
+sockGetStr :: MonadStore s LBS.ByteString
 sockGetStr = getSocketIncremental getByteStringLen
 
-sockGetStrings :: MonadStore [LBS.ByteString]
+sockGetStrings :: MonadStore s [LBS.ByteString]
 sockGetStrings = getSocketIncremental getByteStrings
 
 lBSToText :: LBS.ByteString -> Text

hnix-store-remote/tests/Driver.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}

hnix-store-remote/tests/Operations.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+
+module Operations where
+
+import           Control.Monad
+import           Control.Monad.Except
+import           Control.Monad.Reader
+import           Control.Monad.State
+import           Data.Maybe
+
+import           Data.Proxy
+import           Data.Text.Encoding    ( encodeUtf8 )
+import           Data.Text            as T
+import           Data.Text.Encoding   as T
+import           Data.Text.Lazy       as TL
+import           Data.Text.Lazy.Encoding as TL
+import           Data.ByteString.Char8 as BS
+
+import           System.FilePath
+import           System.Nix.Hash
+import           System.Nix.Internal.Hash
+import           System.Nix.Nar
+import           System.Nix.StorePath
+import           System.Nix.Store.Remote
+import           System.Nix.Store.Remote.Types
+import           System.Nix.Store.Remote.Protocol
+import           System.Nix.Store.Remote.Util
+import           System.Nix.Util
+
+import           Test.Tasty                  as T
+import           Test.Tasty.Hspec
+import qualified Test.Tasty.HUnit            as HU
+import           Test.Tasty.QuickCheck
+import           Text.Read                   (readMaybe)
+
+spec_addToStore :: Spec
+spec_addToStore = do
+
+  describe "addToStore remote operation" $ do
+
+    it "uploads correctly" $ do
+      let name = fromJust $ makeStorePathName "test-recursive-add"
+      let srcPath = "./tests/data/add-recursive"
+      let recursive = True
+      let filter :: FilePathFilter
+          filter path | takeBaseName path == "ignore" = False
+                      | otherwise = True
+      let repair = False
+      res <- runStore $ (addToStore @'SHA256 name srcPath recursive filter repair :: MonadStore "/nix/store" (StorePath "/nix/store"))
+      res `shouldBe` (Right (StorePath (Digest $ T.encodeUtf8 "0mbh3xdb9fkqb2i3iwv6hhz7qiicca83") name),[Last])
+