remote: use proper paths, add nix-derivation support, add tests

Author: sorki

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

@@ -27,13 +27,14 @@ library
                      , bytestring
                      , containers
                      , text
+                     , time
                      , unix
                      , network
                      , mtl
+                     , nix-derivation
+                     , system-filepath
                      , unordered-containers
---                   , pretty-simple
---                   , base16-bytestring
---                   , base32-bytestring
+                     , vector
                      , hnix-store-core
   hs-source-dirs:      src
   default-language:    Haskell2010
@@ -48,4 +49,42 @@ executable hnix-store-temporary-live-test
                      , hnix-store-core
                      , hnix-store-remote
                      , unordered-containers
+                     , nix-derivation
+                     , attoparsec
+                     , text
                      , pretty-simple
+
+test-suite hnix-store-remote-tests
+   ghc-options:       -rtsopts -fprof-auto
+   type:              exitcode-stdio-1.0
+   main-is:           Driver.hs
+   other-modules:
+       NixDaemon
+   hs-source-dirs:    tests
+   build-depends:
+                       attoparsec
+                     , nix-derivation
+                     , hnix-store-core
+                     , hnix-store-remote
+                     , base
+                     , base64-bytestring
+                     , binary
+                     , bytestring
+                     , containers
+                     , directory
+                     , process
+                     , system-filepath
+                     , hspec-expectations-lifted
+                     , tasty
+                     , tasty-discover
+                     , tasty-hspec
+                     , tasty-hunit
+                     , tasty-quickcheck
+                     , linux-namespaces
+                     , temporary
+                     , text
+                     , time
+                     , unix
+                     , unordered-containers
+                     , vector
+   default-language: Haskell2010

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

@@ -4,7 +4,9 @@
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE RecordWildCards     #-}
 module System.Nix.Store.Remote (
     runStore
   , isValidPathUncached
@@ -43,17 +45,20 @@ import           Data.Maybe
 import qualified Data.ByteString.Lazy      as LBS
 import qualified Data.Map.Strict           as M
 import           Data.Proxy                (Proxy(Proxy))
+import           Data.Text                 (Text)
 import qualified Data.Text.Lazy                 as T
 import qualified Data.Text.Lazy.Encoding        as T
 
 import qualified System.Nix.Build          as Build
-import qualified System.Nix.Derivation     as Drv
+import qualified Nix.Derivation            as Drv
+
 import qualified System.Nix.GC             as GC
 import           System.Nix.Hash           (Digest, HashAlgorithm)
 import           System.Nix.Path
 import           System.Nix.Hash
-import           System.Nix.Nar            (localPackNar, putNar, narEffectsIO)
+import           System.Nix.Nar            (localPackNar, putNar, narEffectsIO, Nar)
 import           System.Nix.Util
+import           System.Nix.ValidPath
 
 import           System.Nix.Store.Remote.Types
 import           System.Nix.Store.Remote.Protocol
@@ -70,12 +75,15 @@ type SubstituteFlag = Bool
 --setOptions :: StoreSetting -> MonadStore ()
 
 isValidPathUncached :: Path -> MonadStore Bool
-isValidPathUncached p = simpleOpArgs IsValidPath $ putPath p
+isValidPathUncached p = do
+  sd <- getStoreDir
+  simpleOpArgs IsValidPath $ putPath sd p
 
 queryValidPaths :: PathSet -> SubstituteFlag -> MonadStore PathSet
 queryValidPaths ps substitute = do
+  sd <- getStoreDir
   runOpArgs QueryValidPaths $ do
-    putPaths ps
+    putPaths sd ps
     putBool substitute
   sockGetPaths
 
@@ -86,14 +94,16 @@ queryAllValidPaths = do
 
 querySubstitutablePaths :: PathSet -> MonadStore PathSet
 querySubstitutablePaths ps = do
+  sd <- getStoreDir
   runOpArgs QuerySubstitutablePaths $ do
-    putPaths ps
+    putPaths sd ps
   sockGetPaths
 
 querySubstitutablePathInfos :: PathSet -> MonadStore [SubstitutablePathInfo]
 querySubstitutablePathInfos ps = do
+  sd <- getStoreDir
   runOpArgs QuerySubstitutablePathInfos $ do
-    putPaths ps
+    putPaths sd ps
 
   cnt <- sockGetInt
   forM (take cnt $ cycle [(0 :: Int)]) $ pure $ do
@@ -109,71 +119,80 @@ querySubstitutablePathInfos ps = do
                , narSize = narSize'
                }
 
-queryPathInfoUncached :: Path -> MonadStore ValidPathInfo
-queryPathInfoUncached p = do
+queryPathInfoUncached :: Path -> MonadStore ValidPath
+queryPathInfoUncached path = do
+  sd <- getStoreDir
   runOpArgs QueryPathInfo $ do
-    putPath p
+    putPath sd path
 
   valid <- sockGetBool
   unless valid $ error "Path is not valid"
 
-  drv <- sockGetStr
-  hash' <- lBSToText <$> sockGetStr
-  refs <- sockGetPaths
-  regTime <- sockGetInt
-  size <- sockGetInt
-  ulti <- sockGetBool
-  sigs' <- map lBSToText <$> sockGetStrings
-  ca' <- lBSToText <$> sockGetStr
-  return $ ValidPathInfo {
-             path = p
-           , deriverVP = mkPath drv
-           , narHash = hash'
-           , referencesVP = refs
-           , registrationTime = regTime
-           , narSizeVP = size
-           , ultimate = ulti
-           , sigs = sigs'
-           , ca = ca'
-           }
+  deriver <- mkPath <$> sockGetStr
+  narHash <- lBSToText <$> sockGetStr
+  references <- sockGetPaths
+  registrationTime <- sockGet getTime
+  narSize <- sockGetInt
+  ultimate <- sockGetBool
+  sigs <- map lBSToText <$> sockGetStrings
+  ca <- lBSToText <$> sockGetStr
+  return $ ValidPath {..}
 
 queryReferrers :: Path -> MonadStore PathSet
 queryReferrers p = do
+  sd <- getStoreDir
   runOpArgs QueryReferrers $ do
-    putPath p
+    putPath sd p
   sockGetPaths
 
 queryValidDerivers :: Path -> MonadStore PathSet
 queryValidDerivers p = do
+  sd <- getStoreDir
   runOpArgs QueryValidDerivers $ do
-    putPath p
+    putPath sd p
   sockGetPaths
 
 queryDerivationOutputs :: Path -> MonadStore PathSet
 queryDerivationOutputs p = do
+  sd <- getStoreDir
   runOpArgs QueryDerivationOutputs $
-    putPath p
+    putPath sd p
   sockGetPaths
 
 queryDerivationOutputNames :: Path -> MonadStore PathSet
 queryDerivationOutputNames p = do
+  sd <- getStoreDir
   runOpArgs QueryDerivationOutputNames $
-    putPath p
+    putPath sd p
   sockGetPaths
 
--- XXX: this is broken as I don't know how to get hashes from paths (fix mkPath)
 queryPathFromHashPart :: Digest PathHashAlgo -> MonadStore (Maybe Path)
-queryPathFromHashPart d = do
+queryPathFromHashPart digest = do
   runOpArgs QueryPathFromHashPart $
-    -- TODO: replace `undefined` with digest encoding function when
-    --       [issue 24](https://github.com/haskell-nix/hnix-store/issues/24) is
-    --       closed
-    putByteStringLen $ LBS.fromStrict $ undefined d
+    putText $ printAsBase32 @PathHashAlgo digest
   sockGetPath
 
-type Source = () -- abstract binary source
-addToStoreNar :: ValidPathInfo -> Source -> RepairFlag -> CheckSigsFlag -> MonadStore ()
-addToStoreNar = undefined  -- XXX
+addToStoreNar :: ValidPath -> Nar -> RepairFlag -> CheckSigsFlag -> MonadStore ()
+addToStoreNar ValidPath{..} nar repair checkSigs = do
+  sd <- getStoreDir
+  void $ runOpArgs AddToStoreNar $ do
+    putPath sd path
+    maybe (return ()) (putPath sd) deriver
+    putText narHash -- info.narHash.to_string(Base16, false)
+    putPaths sd references
+    putTime registrationTime
+    putInt narSize
+    putBool ultimate
+    putTexts sigs
+    putText ca
+
+    -- << repair << !checkSigs;
+    putBool repair
+    putBool (not checkSigs)
+
+  -- reference uses copyNAR here to just parse & dump existing NAR from path
+  -- TUNNEL
+  --  putNar nar
 
 printHashType :: HashAlgorithm' Integer -> T.Text
 printHashType MD5             = "MD5"
@@ -212,31 +231,50 @@ addToStore name pth recursive algoProxy pfilter repair = do
 
   fmap (fromMaybe $ error "TODO: Error") sockGetPath
 
-
-addTextToStore :: LBS.ByteString -> LBS.ByteString -> PathSet -> RepairFlag -> MonadStore (Maybe Path)
+-- reference accepts repair but only uses it to throw error in case of nix daemon
+addTextToStore :: Text -> Text -> PathSet -> RepairFlag -> MonadStore (Maybe Path)
 addTextToStore name text references' repair = do
+  when repair $ error "repairing is not supported when building through the Nix daemon"
+  sd <- getStoreDir
   runOpArgs AddTextToStore $ do
-    putByteStringLen name
-    putByteStringLen text
-    putPaths references'
+    putText name
+    putText text
+    putPaths sd references'
   sockGetPath
 
 buildPaths :: PathSet -> Build.BuildMode -> MonadStore ()
-buildPaths ps bm = void $ simpleOpArgs EnsurePath $ do
-  putPaths ps
-  putInt $ fromEnum bm
-
-buildDerivation :: PathName -> Drv.Derivation -> Build.BuildMode -> MonadStore Build.BuildResult
-buildDerivation = undefined  -- XXX
+buildPaths ps bm = do
+  sd <- getStoreDir
+  void $ simpleOpArgs BuildPaths $ do
+    putPaths sd ps
+    putInt $ fromEnum bm
+
+buildDerivation :: Path -> Drv.Derivation -> Build.BuildMode -> MonadStore Build.BuildResult
+buildDerivation p drv buildMode = do
+  sd <- getStoreDir
+  runOpArgs BuildDerivation $ do
+    putPath sd p
+    putDerivation drv
+    putEnum buildMode
+    putInt 0 -- ??????
+
+  res <- getSocketIncremental $ getBuildResult
+  return res
 
 ensurePath :: Path -> MonadStore ()
-ensurePath pn = void $ simpleOpArgs EnsurePath $ putPath pn
+ensurePath pn = do
+  sd <- getStoreDir
+  void $ simpleOpArgs EnsurePath $ putPath sd pn
 
 addTempRoot :: Path -> MonadStore ()
-addTempRoot pn = void $ simpleOpArgs AddTempRoot $ putPath pn
+addTempRoot pn = do
+  sd <- getStoreDir
+  void $ simpleOpArgs AddTempRoot $ putPath sd pn
 
 addIndirectRoot :: Path -> MonadStore ()
-addIndirectRoot pn = void $ simpleOpArgs AddIndirectRoot $ putPath pn
+addIndirectRoot pn = do
+  sd <- getStoreDir
+  void $ simpleOpArgs AddIndirectRoot $ putPath sd pn
 
 syncWithGC :: MonadStore ()
 syncWithGC = void $ simpleOp SyncWithGC
@@ -257,12 +295,15 @@ findRoots = do
 
 collectGarbage :: GC.Options -> MonadStore GC.Result
 collectGarbage opts = do
+  sd <- getStoreDir
   runOpArgs CollectGarbage $ do
     putInt $ fromEnum $ GC.operation opts
-    putPaths $ GC.pathsToDelete opts
+    putPaths sd $ GC.pathsToDelete opts
     putBool $ GC.ignoreLiveness opts
     putInt $ GC.maxFreed opts
-    forM_ [(0 :: Int)..2] $ pure $ putInt (0 :: Int) -- removed options
+    -- removed options
+    -- drop when collectGarbage drops these from nix/src/libstore/remote-store.cc
+    forM_ [(0 :: Int)..2] $ pure $ putInt (0 :: Int)
 
   paths <- sockGetPaths
   freed <- sockGetInt
@@ -273,19 +314,28 @@ collectGarbage opts = do
 optimiseStore :: MonadStore ()
 optimiseStore = void $ simpleOp OptimiseStore
 
+queryMissing :: PathSet -> MonadStore (PathSet, PathSet, PathSet, Integer, Integer)
+queryMissing ps = do
+  sd <- getStoreDir
+  runOpArgs QueryMissing $ do
+    putPaths sd ps
+
+  willBuild <- sockGetPaths
+  willSubstitute <- sockGetPaths
+  unknown <- sockGetPaths
+  downloadSize' <- sockGetInt
+  narSize' <- sockGetInt
+  return (willBuild, willSubstitute, unknown, downloadSize', narSize')
+
 -- returns True on errors
 verifyStore :: CheckFlag -> RepairFlag -> MonadStore Bool
 verifyStore check repair = simpleOpArgs VerifyStore $ do
   putBool check
   putBool repair
 
 addSignatures :: Path -> [LBS.ByteString] -> MonadStore ()
-addSignatures p signatures = void $ simpleOpArgs AddSignatures $ do
-  putPath p
-  putByteStrings signatures
-
--- TODO:
-queryMissing :: PathSet -> MonadStore (PathSet, PathSet, PathSet, Integer, Integer)
-queryMissing ps = undefined --  willBuild willSubstitute unknown downloadSize narSize
-
-
+addSignatures p signatures = do
+  sd <- getStoreDir
+  void $ simpleOpArgs AddSignatures $ do
+    putPath sd p
+    putByteStrings signatures