Implement 'addToStore'

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

@@ -10,6 +10,7 @@ module System.Nix.Hash (
   , HNix.SomeNamedDigest(..)
   , HNix.hash
   , HNix.hashLazy
+  , HNix.mkDigest
 
   , HNix.encodeBase32
   , HNix.encodeBase16

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

@@ -21,7 +21,7 @@ import qualified Data.ByteString.Base16 as Base16
 import           Data.Bits              (xor)
 import qualified Data.ByteString.Lazy   as BSL
 import qualified Data.Hashable          as DataHashable
-import           Data.List              (foldl')
+import           Data.List              (foldl', find)
 import           Data.Proxy             (Proxy(Proxy))
 import           Data.Text              (Text)
 import qualified Data.Text              as T
@@ -76,6 +76,14 @@ instance NamedAlgo 'SHA256 where
 -- | A digest whose 'NamedAlgo' is not known at compile time.
 data SomeNamedDigest = forall a . NamedAlgo a => SomeDigest (Digest a)
 
+-- | Build a valid named digest from its name
+mkDigest :: Text -> BS.ByteString -> Maybe SomeNamedDigest
+mkDigest "sha1"   = Just . SomeDigest . Digest @'SHA1
+mkDigest "sha256" = Just . SomeDigest . Digest @'SHA256
+mkDigest "md5"    = Just . SomeDigest . Digest @'MD5
+mkDigest _        = const Nothing
+
+
 -- | Hash an entire (strict) 'BS.ByteString' as a single call.
 --
 --   For example:

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-core/src/System/Nix/ReadonlyStore.hs

@@ -7,10 +7,20 @@ module System.Nix.ReadonlyStore where
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.HashSet as HS
+import qualified Data.Map as M
+import           Data.Text (Text)
+import qualified Data.Text as T
 import           Data.Text.Encoding
 import           System.Nix.Hash
 import           System.Nix.StorePath
 
+makeOutputPath :: forall storeDir hashAlgo . (KnownStoreDir storeDir, NamedAlgo hashAlgo) => Text -> Digest hashAlgo -> StorePathName -> Maybe (StorePath storeDir)
+makeOutputPath id h nm = makeStorePath ty h <$> name
+  where
+    ty = BS.intercalate ":" ["output", encodeUtf8 id]
+    name = if id == "out" then Just nm else
+      makeStorePathName $ T.concat [unStorePathName nm, "-", id]
+
 makeStorePath :: forall storeDir hashAlgo . (KnownStoreDir storeDir, NamedAlgo hashAlgo) => ByteString -> Digest hashAlgo -> StorePathName -> StorePath storeDir
 makeStorePath ty h nm = StorePath storeHash nm
   where
@@ -23,10 +33,45 @@ makeStorePath ty h nm = StorePath storeHash nm
       ]
     storeHash = hash s
 
+makeType :: (KnownStoreDir storeDir) => ByteString -> StorePathSet storeDir -> ByteString
+makeType name refs = BS.intercalate ":" (name : map storePathToRawFilePath (HS.toList refs))
+
 makeTextPath :: (KnownStoreDir storeDir) => StorePathName -> Digest 'SHA256 -> StorePathSet storeDir -> StorePath storeDir
-makeTextPath nm h refs = makeStorePath ty h nm
+makeTextPath nm h refs = makeStorePath (makeType "text" refs) h nm
+
+makeFixedOutputPath :: forall hashType storeDir. (KnownStoreDir storeDir, NamedAlgo hashType, ValidAlgo hashType)
+    => Bool -> Digest hashType -> StorePathName -> StorePathSet storeDir -> StorePath storeDir
+makeFixedOutputPath recursive digest name refs =
+    if recursive && algoName @hashType == "sha256"
+    then makeStorePath (makeType "source" refs) digest name
+    else if HS.null refs
+      then makeStorePath "output:out" fixedDigest name
+      else error "Old style fixed output path cannot have references"
   where
-    ty = BS.intercalate ":" ("text" : map storePathToRawFilePath (HS.toList refs))
+    fixedDigest = hash @'SHA256 $ BS.concat 
+        [ "fixed:out:"
+        , (if recursive then "r:" else "") 
+        , encodeUtf8 (encodeBase16 digest)
+        , ":"
+        ]
 
 computeStorePathForText :: (KnownStoreDir storeDir) => StorePathName -> ByteString -> StorePathSet storeDir -> StorePath storeDir
 computeStorePathForText nm s refs = makeTextPath nm (hash s) refs
+
+data DerivationOutput storeDir = DerivationOutput
+    { path :: StorePath storeDir
+    , drvHash :: Text
+    , hashAlgo :: HashAlgorithm
+    }
+
+data Derivation storeDir = Derivation
+    { name :: StorePathName
+    , outputs :: M.Map Text (StorePath storeDir)
+    , inputSrcs :: HS.HashSet (StorePath storeDir)
+    , inputDrvs :: M.Map (StorePath storeDir) [Text]
+    , platform :: Text
+    , builder :: Text -- should be typed as a store path
+    , args :: [ Text ]
+    , env :: M.Map Text Text
+    }
+

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,123 @@
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE ViewPatterns        #-}
+
 module System.Nix.Store.Remote (
     runStore
+  , addToStore
+  , addToStore'
+  , addTextToStore
   , syncWithGC
   , optimiseStore
   , verifyStore
+  , RecursiveFlag
+  , RepairFlag
+  , CheckFlag
   ) where
 
+import           Prelude                 as P
 import           Control.Monad
+import           Control.Monad.Except
+
+import           Data.Foldable            ( toList )
+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 =
+    addToStore' @hashType @storeDir name (localPackNar' narEffectsIO srcPath pathFilter) recursive repair
+
+addToStore' :: forall hashType storeDir. (NamedAlgo hashType, ValidAlgo hashType, KnownStoreDir storeDir)
+    => StorePathName
+    -> IO Nar
+    -> RecursiveFlag
+    -> RepairFlag
+    -> MonadStore storeDir (StorePath storeDir)
+addToStore' name narAction recursive repair = do
+  when repair $ throwError "addToStore: Cannot repair when using a daemon."
+  nar <- liftIO narAction
+  runOpArgs AddToStore $ do
+    putByteStringLen $ strToN $ unStorePathName name
+    putBool $ not (recursive && algoName @hashType == "sha256") -- backward compatibility hack
+    putBool recursive
+    putByteStringLen $ strToN (algoName @hashType)
+    putNar nar
+
+  getStorePath
+
+
+makeStorePath :: forall storeDir. KnownStoreDir storeDir => 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)
+
+getStorePath :: forall storeDir. KnownStoreDir storeDir => MonadStore storeDir (StorePath storeDir)
+getStorePath = do
+  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"
+
+strToN :: T.Text -> LBS.ByteString
+strToN = TL.encodeUtf8 . TL.fromStrict
+
+addTextToStore :: forall hashType storeDir. (NamedAlgo hashType, ValidAlgo hashType, KnownStoreDir storeDir)
+    => StorePathName
+    -> TL.Text
+    -> StorePathSet storeDir
+    -> RepairFlag
+    -> MonadStore storeDir (StorePath storeDir)
+addTextToStore name text references repair = do
+  when repair $ throwError "addTextToStore: Cannot repair when using a daemon."
+  runOpArgs AddTextToStore $ do
+    putByteStringLen $ strToN $ unStorePathName name
+    putByteStringLen $ TL.encodeUtf8 text
+    putByteStrings $ P.map (LBS.fromStrict . storePathToRawFilePath) $ toList references
+
+  getStorePath
+
+
+
+

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