diff --git a/docs/01-Contributors.org b/docs/01-Contributors.org index 20d88bf..eefc7eb 100644 --- a/docs/01-Contributors.org +++ b/docs/01-Contributors.org @@ -31,3 +31,4 @@ in order of appearance: + Ryan Trinkle @ryantrinkle + Travis Whitaker @TravisWhitaker + Andrea Bedini @andreabedini ++ Dan Bornside @danbornside diff --git a/hnix-store-core/src/System/Nix/DerivedPath.hs b/hnix-store-core/src/System/Nix/DerivedPath.hs index c53831f..16c8f93 100644 --- a/hnix-store-core/src/System/Nix/DerivedPath.hs +++ b/hnix-store-core/src/System/Nix/DerivedPath.hs @@ -25,12 +25,17 @@ import qualified System.Nix.StorePath data OutputsSpec = OutputsSpec_All + -- ^ Wildcard spec (^*) meaning all outputs | OutputsSpec_Names (Set OutputName) + -- ^ Set of specific outputs deriving (Eq, Generic, Ord, Show) data DerivedPath = DerivedPath_Opaque StorePath + -- ^ Fully evaluated store path that can't be built + -- but can be fetched | DerivedPath_Built StorePath OutputsSpec + -- ^ Derivation path and the outputs built from it deriving (Eq, Generic, Ord, Show) data ParseOutputsError = diff --git a/hnix-store-core/src/System/Nix/Realisation.hs b/hnix-store-core/src/System/Nix/Realisation.hs index 383fd17..353fe5e 100644 --- a/hnix-store-core/src/System/Nix/Realisation.hs +++ b/hnix-store-core/src/System/Nix/Realisation.hs @@ -8,6 +8,7 @@ module System.Nix.Realisation ( , derivationOutputBuilder , derivationOutputParser , Realisation(..) + , RealisationWithId(..) ) where import Crypto.Hash (Digest) @@ -80,8 +81,7 @@ derivationOutputBuilder outputName DerivationOutput{..} = -- -- realisationId is ommited since it is a key -- of type @DerivationOutput OutputName@ so --- we will use a tuple like @(DerivationOutput OutputName, Realisation)@ --- instead. +-- we will use @RealisationWithId@ newtype data Realisation = Realisation { realisationOutPath :: StorePath -- ^ Output path @@ -90,3 +90,14 @@ data Realisation = Realisation , realisationDependencies :: Map (DerivationOutput OutputName) StorePath -- ^ Dependent realisations required for this one to be valid } deriving (Eq, Generic, Ord, Show) + +-- | For wire protocol +-- +-- We store this normalized in @Build.buildResultBuiltOutputs@ +-- as @Map (DerivationOutput OutputName) Realisation@ +-- but wire protocol needs it de-normalized so we +-- need a special (From|To)JSON instances for it +newtype RealisationWithId = RealisationWithId + { unRealisationWithId :: (DerivationOutput OutputName, Realisation) + } + deriving (Eq, Generic, Ord, Show) diff --git a/hnix-store-json/src/System/Nix/JSON.hs b/hnix-store-json/src/System/Nix/JSON.hs index 12a951d..b4d037b 100644 --- a/hnix-store-json/src/System/Nix/JSON.hs +++ b/hnix-store-json/src/System/Nix/JSON.hs @@ -13,7 +13,7 @@ import Data.Aeson import Deriving.Aeson import System.Nix.Base (BaseEncoding(NixBase32)) import System.Nix.OutputName (OutputName) -import System.Nix.Realisation (DerivationOutput, Realisation) +import System.Nix.Realisation (DerivationOutput, Realisation, RealisationWithId(..)) import System.Nix.Signature (Signature) import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, StorePathHashPart) @@ -159,18 +159,18 @@ deriving instance FromJSON Realisation -- For a keyed version of Realisation --- we use (DerivationOutput OutputName, Realisation) +-- we use RealisationWithId (DerivationOutput OutputName, Realisation) -- instead of Realisation.id :: (DerivationOutput OutputName) -- field. -instance {-# OVERLAPPING #-} ToJSON (DerivationOutput OutputName, Realisation) where - toJSON (drvOut, r) = +instance ToJSON RealisationWithId where + toJSON (RealisationWithId (drvOut, r)) = case toJSON r of Object o -> Object $ Data.Aeson.KeyMap.insert "id" (toJSON drvOut) o _ -> error "absurd" -instance {-# OVERLAPPING #-} FromJSON (DerivationOutput OutputName, Realisation) where +instance FromJSON RealisationWithId where parseJSON v@(Object o) = do r <- parseJSON @Realisation v drvOut <- o .: "id" - pure (drvOut, r) + pure (RealisationWithId (drvOut, r)) parseJSON x = fail $ "Expected Object but got " ++ show x diff --git a/hnix-store-remote/README.md b/hnix-store-remote/README.md index cb545cd..566ef50 100644 --- a/hnix-store-remote/README.md +++ b/hnix-store-remote/README.md @@ -14,17 +14,14 @@ via `nix-daemon`. ```haskell {-# LANGUAGE OverloadedStrings #-} -import Control.Monad (void) -import Control.Monad.IO.Class (liftIO) import System.Nix.StorePath (mkStorePathName) import System.Nix.Store.Remote main :: IO () main = do - void $ runStore $ do + runStore $ do syncWithGC roots <- findRoots - liftIO $ print roots res <- case mkStorePathName "hnix-store" of Left e -> error (show e) @@ -33,5 +30,7 @@ main = do (StoreText name "Hello World!") mempty RepairMode_DontRepair - liftIO $ print res + + pure (roots, res) + >>= print ``` diff --git a/hnix-store-remote/app/BuildDerivation.hs b/hnix-store-remote/app/BuildDerivation.hs index ee4d4cb..1d321c7 100644 --- a/hnix-store-remote/app/BuildDerivation.hs +++ b/hnix-store-remote/app/BuildDerivation.hs @@ -2,39 +2,23 @@ module Main where import Data.Default.Class (Default(def)) -import Data.Text (Text) -import System.Nix.Derivation (Derivation) -import System.Nix.StorePath (StorePath) import qualified Data.Text -import qualified Data.Text.IO -import qualified Data.Attoparsec.Text import qualified System.Environment import qualified System.Nix.Build -import qualified System.Nix.Derivation import qualified System.Nix.StorePath import qualified System.Nix.Store.Remote -parseDerivation :: FilePath -> IO (Derivation StorePath Text) -parseDerivation source = do - contents <- Data.Text.IO.readFile source - case Data.Attoparsec.Text.parseOnly - (System.Nix.Derivation.parseDerivation def) contents of - Left e -> error e - Right drv -> pure drv - main :: IO () main = System.Environment.getArgs >>= \case [filename] -> do case System.Nix.StorePath.parsePathFromText def (Data.Text.pack filename) of Left e -> error $ show e Right p -> do - d <- parseDerivation filename out <- System.Nix.Store.Remote.runStore $ System.Nix.Store.Remote.buildDerivation p - d System.Nix.Build.BuildMode_Normal print out _ -> error "No input derivation file" diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 5546c10..b4c8c73 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -46,11 +46,6 @@ common commons , ViewPatterns default-language: Haskell2010 -common tests - import: commons - build-tool-depends: - tasty-discover:tasty-discover - flag io-testsuite default: False @@ -119,7 +114,9 @@ library , data-default-class , dependent-sum > 0.7 , dependent-sum-template >= 0.2.0.1 && < 0.3 +-- , directory , dlist >= 1.0 + , exceptions , generic-arbitrary < 1.1 , hashable , text @@ -139,7 +136,6 @@ executable build-derivation buildable: False build-depends: base >=4.12 && <5 - , attoparsec , hnix-store-core , hnix-store-remote , data-default-class @@ -163,7 +159,7 @@ executable remote-readme ghc-options: -pgmL markdown-unlit -Wall test-suite remote - import: tests + import: commons type: exitcode-stdio-1.0 main-is: Driver.hs hs-source-dirs: tests @@ -187,7 +183,7 @@ test-suite remote , QuickCheck test-suite remote-io - import: tests + import: commons if !flag(io-testsuite) || os(darwin) buildable: False @@ -206,9 +202,11 @@ test-suite remote-io , hnix-store-remote , hnix-store-tests , bytestring + , concurrency , containers , crypton , directory + , exceptions , filepath , hspec , hspec-expectations-lifted diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index cf4b23e..53c3737 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} + module System.Nix.Store.Remote - ( - module System.Nix.Store.Types + ( module System.Nix.Store.Types , module System.Nix.Store.Remote.Client , module System.Nix.Store.Remote.MonadStore , module System.Nix.Store.Remote.Types @@ -8,79 +10,190 @@ module System.Nix.Store.Remote , MonadStore -- * Runners , runStore - , runStoreOpts - , runStoreOptsTCP + , runStoreConnection + , runStoreSocket + -- ** Daemon + , runDaemon + , runDaemonConnection + , justdoit ) where +import Control.Monad.Catch (MonadMask) +import Control.Monad.Conc.Class (MonadConc) +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Default.Class (Default(def)) import Network.Socket (Family, SockAddr(SockAddrUnix)) import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) -import System.Nix.StorePath (StoreDir) -import System.Nix.Store.Remote.MonadStore (RemoteStoreT, getStoreDir, RemoteStoreError(RemoteStoreError_GetAddrInfoFailed)) +import System.Nix.Store.Remote.MonadStore + ( runRemoteStoreT + , MonadRemoteStore(..) + , RemoteStoreT + , RemoteStoreError(RemoteStoreError_GetAddrInfoFailed)) import System.Nix.Store.Remote.Client +import System.Nix.Store.Remote.Server (WorkerHelper, runProxyDaemon) import System.Nix.Store.Remote.Types -import qualified Control.Exception +import qualified Control.Monad.Catch import qualified Network.Socket +-- see TODO bellow +--import qualified System.Directory + +-- wip justdoit +import System.Nix.StorePath (StorePath) +import qualified System.Nix.StorePath -- * Compat -type MonadStore = RemoteStoreT StoreConfig IO +type MonadStore = RemoteStoreT IO -- * Runners -runStore :: MonadStore a -> Run IO a -runStore = runStoreOpts defaultSockPath def - where - defaultSockPath :: String - defaultSockPath = "/nix/var/nix/daemon-socket/socket" +runStore + :: ( MonadIO m + , MonadMask m + ) + => RemoteStoreT m a + -> Run m a +runStore = runStoreConnection def -runStoreOpts - :: FilePath - -> StoreDir - -> MonadStore a - -> Run IO a -runStoreOpts socketPath = - runStoreOpts' - Network.Socket.AF_UNIX - (SockAddrUnix socketPath) +runStoreConnection + :: ( MonadIO m + , MonadMask m + ) + => StoreConnection + -> RemoteStoreT m a + -> Run m a +runStoreConnection sc k = + connectionToSocket sc + >>= \case + Left e -> pure (Left e, mempty) + Right (fam, sock) -> runStoreSocket fam sock k -runStoreOptsTCP - :: String - -> Int - -> StoreDir - -> MonadStore a - -> Run IO a -runStoreOptsTCP host port sd code = do - Network.Socket.getAddrInfo - (Just Network.Socket.defaultHints) - (Just host) - (Just $ show port) - >>= \case - (sockAddr:_) -> - runStoreOpts' - (Network.Socket.addrFamily sockAddr) - (Network.Socket.addrAddress sockAddr) - sd - code - _ -> pure (Left RemoteStoreError_GetAddrInfoFailed, mempty) - -runStoreOpts' - :: Family +runStoreSocket + :: ( MonadIO m + , MonadMask m + ) + => Family -> SockAddr - -> StoreDir - -> MonadStore a - -> Run IO a -runStoreOpts' sockFamily sockAddr storeRootDir code = - Control.Exception.bracket - open - (Network.Socket.close . hasStoreSocket) - (flip runStoreSocket code) + -> RemoteStoreT m a + -> Run m a +runStoreSocket sockFamily sockAddr code = + Control.Monad.Catch.bracket + (liftIO open) + (liftIO . Network.Socket.close . hasStoreSocket) + (\s -> runRemoteStoreT s $ greetServer >> code) where open = do - soc <- Network.Socket.socket sockFamily Network.Socket.Stream 0 + soc <- + Network.Socket.socket + sockFamily + Network.Socket.Stream + Network.Socket.defaultProtocol Network.Socket.connect soc sockAddr - pure PreStoreConfig - { preStoreConfig_socket = soc - , preStoreConfig_dir = storeRootDir - } + pure soc + +justdoit :: Run IO (Bool, Bool) +justdoit = do + runDaemonConnection runStore (pure ()) (StoreConnection_Socket "/tmp/dsock") $ + runStoreConnection (StoreConnection_Socket "/tmp/dsock") + $ do + a <- isValidPath pth + b <- isValidPath pth + pure (a, b) + where + pth :: StorePath + pth = + either (error . show) id + $ System.Nix.StorePath.parsePathFromText + def + "/nix/store/yyznqbwam67cmp7zfwk0rkgmi9yqsdsm-hnix-store-core-0.8.0.0" + +runDaemon + :: forall m a + . ( MonadIO m + , MonadConc m + ) + => WorkerHelper m + -> m a + -> m a +runDaemon workerHelper = + runDaemonConnection + workerHelper + (pure ()) + def + +-- | Run an emulated nix daemon using given @StoreConnection@ +-- the deamon will close when the continuation returns. +runDaemonConnection + :: forall m a + . ( MonadIO m + , MonadConc m + ) + => WorkerHelper m + -> RemoteStoreT m () + -> StoreConnection + -> m a + -> m a +runDaemonConnection workerHelper postGreet sc k = + connectionToSocket sc + >>= \case + Left e -> error $ show e + Right (fam, sock) -> runDaemonSocket workerHelper postGreet fam sock k + +-- | Run an emulated nix daemon using given @StoreConnection@ +-- the deamon will close when the continuation returns. +runDaemonSocket + :: forall m a + . ( MonadIO m + , MonadConc m + ) + => WorkerHelper m + -> RemoteStoreT m () + -> Family + -> SockAddr + -> m a + -> m a +runDaemonSocket workerHelper postGreet sockFamily sockAddr k = + Control.Monad.Catch.bracket + (liftIO + $ Network.Socket.socket + sockFamily + Network.Socket.Stream + Network.Socket.defaultProtocol + ) + (\lsock -> liftIO $ Network.Socket.close lsock) + $ \lsock -> do + -- TODO: the: (\lsock -> liftIO $ Network.Socket.close lsock *> System.Directory.removeFile f) + -- branch should really be (and even removeFile is currently omitted) + -- a file lock followed by unlink *before* bind rather than after close. If + -- the program crashes (or loses power or something) then a stale unix + -- socket will stick around and prevent the daemon from starting. using a + -- lock file instead means only one "copy" of the daemon can hold the lock, + -- and can safely unlink the socket before binding no matter how shutdown + -- occured. + + -- set up the listening socket + liftIO $ Network.Socket.bind lsock sockAddr + runProxyDaemon workerHelper postGreet lsock k + +connectionToSocket + :: MonadIO m + => StoreConnection + -> m (Either RemoteStoreError (Family, SockAddr)) +connectionToSocket (StoreConnection_Socket (StoreSocketPath f)) = + pure $ pure + ( Network.Socket.AF_UNIX + , SockAddrUnix f + ) +connectionToSocket (StoreConnection_TCP StoreTCP{..}) = do + addrInfo <- liftIO $ Network.Socket.getAddrInfo + (Just Network.Socket.defaultHints) + (Just storeTCPHost) + (Just $ show storeTCPPort) + case addrInfo of + (sockAddr:_) -> + pure $ pure + ( Network.Socket.addrFamily sockAddr + , Network.Socket.addrAddress sockAddr + ) + _ -> pure (Left RemoteStoreError_GetAddrInfoFailed) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs index 0b9386f..3a08a87 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs @@ -17,8 +17,8 @@ deriving via GenericArbitrary CheckMode deriving via GenericArbitrary SubstituteMode instance Arbitrary SubstituteMode -deriving via GenericArbitrary TestStoreConfig - instance Arbitrary TestStoreConfig +deriving via GenericArbitrary ProtoStoreConfig + instance Arbitrary ProtoStoreConfig deriving via GenericArbitrary ProtoVersion instance Arbitrary ProtoVersion diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 820747d..0b744d8 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -32,10 +32,8 @@ import Data.HashSet (HashSet) import Data.Map (Map) import Data.Set (Set) import Data.Some (Some) -import Data.Text (Text) import System.Nix.Build (BuildMode, BuildResult) -import System.Nix.Derivation (Derivation) import System.Nix.DerivedPath (DerivedPath) import System.Nix.Hash (HashAlgo(..)) import System.Nix.Nar (NarSource) @@ -52,6 +50,12 @@ import System.Nix.Store.Remote.Types.SubstituteMode (SubstituteMode) import System.Nix.Store.Remote.Client.Core import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) +import qualified Control.Monad.IO.Class +import qualified Data.Attoparsec.Text +import qualified Data.Text.IO +import qualified System.Nix.Derivation +import qualified System.Nix.StorePath + -- | Add `NarSource` to the store addToStore :: MonadRemoteStore m @@ -114,10 +118,18 @@ addIndirectRoot = doReq . AddIndirectRoot buildDerivation :: MonadRemoteStore m => StorePath - -> Derivation StorePath Text -> BuildMode -> m BuildResult -buildDerivation a b c = doReq (BuildDerivation a b c) +buildDerivation sp mode = do + sd <- getStoreDir + drvContents <- + Control.Monad.IO.Class.liftIO + $ Data.Text.IO.readFile + $ System.Nix.StorePath.storePathToFilePath sd sp + case Data.Attoparsec.Text.parseOnly + (System.Nix.Derivation.parseDerivation sd) drvContents of + Left e -> throwError $ RemoteStoreError_DerivationParse e + Right drv -> doReq (BuildDerivation sp drv mode) -- | Build paths if they are an actual derivations. -- diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs index 8837c06..e16da08 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs @@ -1,6 +1,6 @@ module System.Nix.Store.Remote.Client.Core ( Run - , runStoreSocket + , greetServer , doReq ) where @@ -12,13 +12,8 @@ import Data.Some (Some(Some)) import System.Nix.Nar (NarSource) import System.Nix.Store.Remote.Logger (processOutput) import System.Nix.Store.Remote.MonadStore - ( MonadRemoteStore + ( MonadRemoteStore(..) , RemoteStoreError(..) - , RemoteStoreT - , runRemoteStoreT - , mapStoreConfig - , takeNarSource - , getStoreSocket ) import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) import System.Nix.Store.Remote.Serializer @@ -31,10 +26,9 @@ import System.Nix.Store.Remote.Serializer , trustedFlag , workerMagic ) -import System.Nix.Store.Remote.Types.Handshake (ClientHandshakeInput(..), ClientHandshakeOutput(..)) +import System.Nix.Store.Remote.Types.Handshake (ClientHandshakeOutput(..)) import System.Nix.Store.Remote.Types.Logger (Logger) -import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion) -import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig) +import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..)) import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) import System.Nix.Store.Remote.Types.StoreReply (StoreReply(..)) import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) @@ -84,91 +78,68 @@ doReq = \case $ getReplyS @a ) -runStoreSocket - :: ( Monad m - , MonadIO m - ) - => PreStoreConfig - -> RemoteStoreT StoreConfig m a - -> Run m a -runStoreSocket preStoreConfig code = - runRemoteStoreT preStoreConfig $ do - ClientHandshakeOutput{..} - <- greet - ClientHandshakeInput - { clientHandshakeInputOurVersion = ourProtoVersion - } +greetServer + :: MonadRemoteStore m + => m ClientHandshakeOutput +greetServer = do + sockPutS + (mapErrorS + RemoteStoreError_SerializerHandshake + workerMagic + ) + WorkerMagic_One - mapStoreConfig - (preStoreConfigToStoreConfig - clientHandshakeOutputLeastCommonVerison) - code + magic <- + sockGetS + $ mapErrorS + RemoteStoreError_SerializerHandshake + workerMagic - where - greet - :: MonadIO m - => ClientHandshakeInput - -> RemoteStoreT PreStoreConfig m ClientHandshakeOutput - greet ClientHandshakeInput{..} = do + unless + (magic == WorkerMagic_Two) + $ throwError RemoteStoreError_WorkerMagic2Mismatch - sockPutS - (mapErrorS - RemoteStoreError_SerializerHandshake - workerMagic - ) - WorkerMagic_One + daemonVersion <- sockGetS protoVersion - magic <- + when (daemonVersion < ProtoVersion 1 10) + $ throwError RemoteStoreError_ClientVersionTooOld + + pv <- getProtoVersion + sockPutS protoVersion pv + + let leastCommonVersion = min daemonVersion pv + + when (leastCommonVersion >= ProtoVersion 1 14) + $ sockPutS int (0 :: Int) -- affinity, obsolete + + when (leastCommonVersion >= ProtoVersion 1 11) $ do + sockPutS + (mapErrorS RemoteStoreError_SerializerPut bool) + False -- reserveSpace, obsolete + + daemonNixVersion <- if leastCommonVersion >= ProtoVersion 1 33 + then do + -- If we were buffering I/O, we would flush the output here. + txtVer <- sockGetS - $ mapErrorS - RemoteStoreError_SerializerHandshake - workerMagic + $ mapErrorS + RemoteStoreError_SerializerGet + text + pure $ Just txtVer + else pure Nothing - unless - (magic == WorkerMagic_Two) - $ throwError RemoteStoreError_WorkerMagic2Mismatch + remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35 + then do + sockGetS + $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag + else pure Nothing - daemonVersion <- sockGetS protoVersion + setProtoVersion leastCommonVersion + processOutput - when (daemonVersion < ProtoVersion 1 10) - $ throwError RemoteStoreError_ClientVersionTooOld - - sockPutS protoVersion clientHandshakeInputOurVersion - - let leastCommonVersion = min daemonVersion ourProtoVersion - - when (leastCommonVersion >= ProtoVersion 1 14) - $ sockPutS int (0 :: Int) -- affinity, obsolete - - when (leastCommonVersion >= ProtoVersion 1 11) $ do - sockPutS - (mapErrorS RemoteStoreError_SerializerPut bool) - False -- reserveSpace, obsolete - - daemonNixVersion <- if leastCommonVersion >= ProtoVersion 1 33 - then do - -- If we were buffering I/O, we would flush the output here. - txtVer <- - sockGetS - $ mapErrorS - RemoteStoreError_SerializerGet - text - pure $ Just txtVer - else pure Nothing - - remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35 - then do - sockGetS - $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag - else pure Nothing - - mapStoreConfig - (preStoreConfigToStoreConfig leastCommonVersion) - processOutput - - pure ClientHandshakeOutput - { clientHandshakeOutputNixVersion = daemonNixVersion - , clientHandshakeOutputTrust = remoteTrustsUs - , clientHandshakeOutputLeastCommonVerison = leastCommonVersion - , clientHandshakeOutputServerVersion = daemonVersion - } + pure ClientHandshakeOutput + { clientHandshakeOutputNixVersion = daemonNixVersion + , clientHandshakeOutputTrust = remoteTrustsUs + , clientHandshakeOutputLeastCommonVersion = leastCommonVersion + , clientHandshakeOutputServerVersion = daemonVersion + } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs index debe4e7..12b3c9e 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -8,22 +8,21 @@ module System.Nix.Store.Remote.MonadStore , WorkerException(..) , RemoteStoreT , runRemoteStoreT - , mapStoreConfig - , MonadRemoteStoreR(..) - , MonadRemoteStore - , getProtoVersion + , MonadRemoteStore(..) ) where import Control.Exception (SomeException) +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Except (MonadError) import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (MonadReader, ask, asks) -import Control.Monad.State.Strict (get, modify) +import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.State.Strict (get, gets, modify) import Control.Monad.Trans (MonadTrans, lift) -import Control.Monad.Trans.State.Strict (StateT, runStateT, mapStateT) -import Control.Monad.Trans.Except (ExceptT, runExceptT, mapExceptT) -import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT) +import Control.Monad.Trans.State.Strict (StateT, runStateT) +import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Data.ByteString (ByteString) +import Data.Default.Class (Default(def)) import Data.DList (DList) import Data.Word (Word64) import Network.Socket (Socket) @@ -32,29 +31,36 @@ import System.Nix.StorePath (HasStoreDir(..), StoreDir) import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, RequestSError, ReplySError, SError) import System.Nix.Store.Remote.Types.Logger (Logger, BasicError, ErrorInfo) import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion) -import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..), StoreConfig) +import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig(..)) import qualified Data.DList data RemoteStoreState = RemoteStoreState { - remoteStoreState_logs :: DList Logger - , remoteStoreState_gotError :: Bool - , remoteStoreState_mDataSource :: Maybe (Word64 -> IO (Maybe ByteString)) + remoteStoreStateConfig :: ProtoStoreConfig + , remoteStoreStateLogs :: DList Logger + , remoteStoreStateMDataSource :: Maybe (Word64 -> IO (Maybe ByteString)) -- ^ Source for @Logger_Read@, this will be called repeatedly -- as the daemon requests chunks of size @Word64@. -- If the function returns Nothing and daemon tries to read more -- data an error is thrown. -- Used by @AddToStoreNar@ and @ImportPaths@ operations. - , remoteStoreState_mDataSink :: Maybe (ByteString -> IO ()) + , remoteStoreStateMDataSink :: Maybe (ByteString -> IO ()) -- ^ Sink for @Logger_Write@, called repeatedly by the daemon -- to dump us some data. Used by @ExportPath@ operation. - , remoteStoreState_mNarSource :: Maybe (NarSource IO) + , remoteStoreStateMNarSource :: Maybe (NarSource IO) } +instance HasStoreDir RemoteStoreState where + hasStoreDir = hasStoreDir . remoteStoreStateConfig + +instance HasProtoVersion RemoteStoreState where + hasProtoVersion = hasProtoVersion . remoteStoreStateConfig + data RemoteStoreError = RemoteStoreError_Fixme String | RemoteStoreError_BuildFailed | RemoteStoreError_ClientVersionTooOld + | RemoteStoreError_DerivationParse String | RemoteStoreError_Disconnected | RemoteStoreError_GetAddrInfoFailed | RemoteStoreError_GenericIncrementalLeftovers String ByteString -- when there are bytes left over after genericIncremental parser is done, (Done x leftover), first param is show x @@ -69,9 +75,9 @@ data RemoteStoreError | RemoteStoreError_LoggerError (Either BasicError ErrorInfo) | RemoteStoreError_LoggerLeftovers String ByteString -- when there are bytes left over after incremental logger parser is done, (Done x leftover), first param is show x | RemoteStoreError_LoggerParserFail String ByteString -- when incremental parser returns ((Fail msg leftover) :: Result) - | RemoteStoreError_NoDataSourceProvided -- remoteStoreState_mDataSource is required but it is Nothing - | RemoteStoreError_DataSourceExhausted -- remoteStoreState_mDataSource returned Nothing but more data was requested - | RemoteStoreError_NoDataSinkProvided -- remoteStoreState_mDataSink is required but it is Nothing + | RemoteStoreError_NoDataSourceProvided -- remoteStoreStateMDataSource is required but it is Nothing + | RemoteStoreError_DataSourceExhausted -- remoteStoreStateMDataSource returned Nothing but more data was requested + | RemoteStoreError_NoDataSinkProvided -- remoteStoreStateMDataSink is required but it is Nothing | RemoteStoreError_NoNarSourceProvided | RemoteStoreError_OperationFailed | RemoteStoreError_ProtocolMismatch @@ -100,91 +106,116 @@ data WorkerError | WorkerError_UnsupportedOperation deriving (Eq, Ord, Show) -newtype RemoteStoreT r m a = RemoteStoreT +newtype RemoteStoreT m a = RemoteStoreT { _unRemoteStoreT :: ExceptT RemoteStoreError (StateT RemoteStoreState - (ReaderT r m)) a + (ReaderT Socket m)) a } deriving ( Functor , Applicative , Monad - , MonadReader r + , MonadReader Socket --, MonadState StoreState -- Avoid making the internal state explicit , MonadError RemoteStoreError + , MonadCatch + , MonadMask + , MonadThrow , MonadIO ) -instance MonadTrans (RemoteStoreT r) where +instance MonadTrans RemoteStoreT where lift = RemoteStoreT . lift . lift . lift -- | Runner for @RemoteStoreT@ runRemoteStoreT - :: ( HasStoreDir r - , HasStoreSocket r - , Monad m - ) - => r - -> RemoteStoreT r m a + :: Monad m + => Socket + -> RemoteStoreT m a -> m (Either RemoteStoreError a, DList Logger) -runRemoteStoreT r = - fmap (\(res, RemoteStoreState{..}) -> (res, remoteStoreState_logs)) - . (`runReaderT` r) +runRemoteStoreT sock = + fmap (\(res, RemoteStoreState{..}) -> (res, remoteStoreStateLogs)) + . (`runReaderT` sock) . (`runStateT` emptyState) . runExceptT . _unRemoteStoreT where emptyState = RemoteStoreState - { remoteStoreState_logs = mempty - , remoteStoreState_gotError = False - , remoteStoreState_mDataSource = Nothing - , remoteStoreState_mDataSink = Nothing - , remoteStoreState_mNarSource = Nothing + { remoteStoreStateConfig = def + , remoteStoreStateLogs = mempty + , remoteStoreStateMDataSource = Nothing + , remoteStoreStateMDataSink = Nothing + , remoteStoreStateMNarSource = Nothing } -mapStoreConfig - :: (rb -> ra) - -> (RemoteStoreT ra m a -> RemoteStoreT rb m a) -mapStoreConfig f = - RemoteStoreT - . ( mapExceptT - . mapStateT - . withReaderT - ) f - . _unRemoteStoreT - class ( MonadIO m , MonadError RemoteStoreError m - , HasStoreSocket r - , HasStoreDir r - , MonadReader r m ) - => MonadRemoteStoreR r m where + => MonadRemoteStore m where appendLog :: Logger -> m () default appendLog :: ( MonadTrans t - , MonadRemoteStoreR r m' + , MonadRemoteStore m' , m ~ t m' ) => Logger -> m () appendLog = lift . appendLog + getConfig :: m ProtoStoreConfig + default getConfig + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m ProtoStoreConfig + getConfig = lift getConfig + getStoreDir :: m StoreDir default getStoreDir :: ( MonadTrans t - , MonadRemoteStoreR r m' + , MonadRemoteStore m' , m ~ t m' ) => m StoreDir getStoreDir = lift getStoreDir + setStoreDir :: StoreDir -> m () + default setStoreDir + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => StoreDir + -> m () + setStoreDir = lift . setStoreDir + + -- | Get @ProtoVersion@ from state + getProtoVersion :: m ProtoVersion + default getProtoVersion + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m ProtoVersion + getProtoVersion = lift getProtoVersion + + setProtoVersion :: ProtoVersion -> m () + default setProtoVersion + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => ProtoVersion + -> m () + setProtoVersion = lift . setProtoVersion + getStoreSocket :: m Socket default getStoreSocket :: ( MonadTrans t - , MonadRemoteStoreR r m' + , MonadRemoteStore m' , m ~ t m' ) => m Socket @@ -193,7 +224,7 @@ class ( MonadIO m setNarSource :: NarSource IO -> m () default setNarSource :: ( MonadTrans t - , MonadRemoteStoreR r m' + , MonadRemoteStore m' , m ~ t m' ) => NarSource IO @@ -203,7 +234,7 @@ class ( MonadIO m takeNarSource :: m (Maybe (NarSource IO)) default takeNarSource :: ( MonadTrans t - , MonadRemoteStoreR r m' + , MonadRemoteStore m' , m ~ t m' ) => m (Maybe (NarSource IO)) @@ -212,7 +243,7 @@ class ( MonadIO m setDataSource :: (Word64 -> IO (Maybe ByteString)) -> m () default setDataSource :: ( MonadTrans t - , MonadRemoteStoreR r m' + , MonadRemoteStore m' , m ~ t m' ) => (Word64 -> IO (Maybe ByteString)) @@ -222,7 +253,7 @@ class ( MonadIO m getDataSource :: m (Maybe (Word64 -> IO (Maybe ByteString))) default getDataSource :: ( MonadTrans t - , MonadRemoteStoreR r m' + , MonadRemoteStore m' , m ~ t m' ) => m (Maybe (Word64 -> IO (Maybe ByteString))) @@ -231,7 +262,7 @@ class ( MonadIO m clearDataSource :: m () default clearDataSource :: ( MonadTrans t - , MonadRemoteStoreR r m' + , MonadRemoteStore m' , m ~ t m' ) => m () @@ -240,7 +271,7 @@ class ( MonadIO m setDataSink :: (ByteString -> IO ()) -> m () default setDataSink :: ( MonadTrans t - , MonadRemoteStoreR r m' + , MonadRemoteStore m' , m ~ t m' ) => (ByteString -> IO ()) @@ -250,7 +281,7 @@ class ( MonadIO m getDataSink :: m (Maybe (ByteString -> IO ())) default getDataSink :: ( MonadTrans t - , MonadRemoteStoreR r m' + , MonadRemoteStore m' , m ~ t m' ) => m (Maybe (ByteString -> IO ())) @@ -259,50 +290,49 @@ class ( MonadIO m clearDataSink :: m () default clearDataSink :: ( MonadTrans t - , MonadRemoteStoreR r m' + , MonadRemoteStore m' , m ~ t m' ) => m () clearDataSink = lift clearDataSink -instance MonadRemoteStoreR r m => MonadRemoteStoreR r (StateT s m) -instance MonadRemoteStoreR r m => MonadRemoteStoreR r (ReaderT r m) -instance MonadRemoteStoreR r m => MonadRemoteStoreR r (ExceptT RemoteStoreError m) +instance MonadRemoteStore m => MonadRemoteStore (StateT s m) +instance MonadRemoteStore m => MonadRemoteStore (ReaderT r m) +instance MonadRemoteStore m => MonadRemoteStore (ExceptT RemoteStoreError m) -type MonadRemoteStore m = MonadRemoteStoreR StoreConfig m +instance MonadIO m => MonadRemoteStore (RemoteStoreT m) where -instance ( MonadIO m - , HasStoreDir r - , HasStoreSocket r - ) - => MonadRemoteStoreR r (RemoteStoreT r m) where + getConfig = RemoteStoreT $ gets remoteStoreStateConfig + getProtoVersion = RemoteStoreT $ gets hasProtoVersion + setProtoVersion pv = + RemoteStoreT $ modify $ \s -> + s { remoteStoreStateConfig = + (remoteStoreStateConfig s) { protoStoreConfigProtoVersion = pv } + } + getStoreDir = RemoteStoreT $ gets hasStoreDir + setStoreDir sd = + RemoteStoreT $ modify $ \s -> + s { remoteStoreStateConfig = + (remoteStoreStateConfig s) { protoStoreConfigDir = sd } + } - getStoreDir = hasStoreDir <$> RemoteStoreT ask - getStoreSocket = hasStoreSocket <$> RemoteStoreT ask + getStoreSocket = RemoteStoreT ask appendLog x = RemoteStoreT $ modify - $ \s -> s { remoteStoreState_logs = remoteStoreState_logs s `Data.DList.snoc` x } + $ \s -> s { remoteStoreStateLogs = remoteStoreStateLogs s `Data.DList.snoc` x } - setDataSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = pure x } - getDataSource = remoteStoreState_mDataSource <$> RemoteStoreT get - clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = Nothing } + setDataSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSource = pure x } + getDataSource = RemoteStoreT (gets remoteStoreStateMDataSource) + clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSource = Nothing } - setDataSink x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSink = pure x } - getDataSink = remoteStoreState_mDataSink <$> RemoteStoreT get - clearDataSink = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSink = Nothing } + setDataSink x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSink = pure x } + getDataSink = RemoteStoreT (gets remoteStoreStateMDataSink) + clearDataSink = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSink = Nothing } - setNarSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mNarSource = pure x } + setNarSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMNarSource = pure x } takeNarSource = RemoteStoreT $ do - x <- remoteStoreState_mNarSource <$> get - modify $ \s -> s { remoteStoreState_mNarSource = Nothing } + x <- remoteStoreStateMNarSource <$> get + modify $ \s -> s { remoteStoreStateMNarSource = Nothing } pure x - --- | Ask for a @StoreDir@ -getProtoVersion - :: ( MonadRemoteStoreR r m - , HasProtoVersion r - ) - => m ProtoVersion -getProtoVersion = asks hasProtoVersion diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 42f3255..7d25d15 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -131,7 +131,7 @@ import System.Nix.DerivedPath (DerivedPath(..), ParseOutputsError) import System.Nix.Hash (HashAlgo(..)) import System.Nix.JSON () import System.Nix.OutputName (OutputName) -import System.Nix.Realisation (DerivationOutputError, Realisation(..)) +import System.Nix.Realisation (DerivationOutputError, Realisation(..), RealisationWithId(..)) import System.Nix.Signature (Signature, NarSignature) import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) import System.Nix.StorePath (HasStoreDir(..), InvalidNameError, InvalidPathError, StorePath, StorePathHashPart, StorePathName) @@ -1398,7 +1398,7 @@ derivationOutputTyped = mapErrorS ReplySError_DerivationOutput $ realisation :: NixSerializer r ReplySError Realisation realisation = mapErrorS ReplySError_Realisation json -realisationWithId :: NixSerializer r ReplySError (System.Nix.Realisation.DerivationOutput OutputName, Realisation) +realisationWithId :: NixSerializer r ReplySError RealisationWithId realisationWithId = mapErrorS ReplySError_RealisationWithId json -- *** BuildResult @@ -1434,7 +1434,7 @@ buildResult = Serializer then pure . Data.Map.Strict.fromList - . map (\(_, (a, b)) -> (a, b)) + . map (\(_, RealisationWithId (a, b)) -> (a, b)) . Data.Map.Strict.toList <$> getS (mapS derivationOutputTyped realisationWithId) else pure Nothing @@ -1453,7 +1453,7 @@ buildResult = Serializer Control.Monad.when (protoVersion_minor pv >= 28) $ putS (mapS derivationOutputTyped realisationWithId) $ Data.Map.Strict.fromList - $ map (\(a, b) -> (a, (a, b))) + $ map (\(a, b) -> (a, RealisationWithId (a, b))) $ Data.Map.Strict.toList $ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs index 41cd473..e22b3a7 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs @@ -1,69 +1,81 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} -module System.Nix.Store.Remote.Server where +module System.Nix.Store.Remote.Server + ( runProxyDaemon + , WorkerHelper + ) + where import Control.Concurrent.Classy.Async import Control.Monad (join, void, when) import Control.Monad.Conc.Class (MonadConc) import Control.Monad.Except (MonadError, throwError) -import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Trans (lift) import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Default.Class (Default(def)) import Data.Foldable (traverse_) import Data.IORef (IORef, atomicModifyIORef, newIORef) -import Data.Some (Some(Some)) import Data.Text (Text) import Data.Void (Void, absurd) import Data.Word (Word32) -import qualified Data.Text -import qualified Data.Text.IO import Network.Socket (Socket, accept, close, listen, maxListenQueue) -import System.Nix.StorePath (StoreDir) -import System.Nix.Store.Remote.Serializer as RB +import System.Nix.Nar (NarSource) +import System.Nix.Store.Remote.Client (Run, doReq) +import System.Nix.Store.Remote.Serializer (LoggerSError, mapErrorS, storeRequest, workerMagic, protoVersion, int, logger, text, trustedFlag) import System.Nix.Store.Remote.Socket import System.Nix.Store.Remote.Types.StoreRequest as R -import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..), StoreConfig(..), PreStoreConfig(..), preStoreConfigToStoreConfig) -import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..)) +import System.Nix.Store.Remote.Types.StoreReply +import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..)) import System.Nix.Store.Remote.Types.Logger (BasicError(..), ErrorInfo, Logger(..)) - -import System.Nix.Store.Remote.MonadStore (WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT, mapStoreConfig) +import System.Nix.Store.Remote.MonadStore (MonadRemoteStore(..), WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT) import System.Nix.Store.Remote.Types.Handshake (ServerHandshakeInput(..), ServerHandshakeOutput(..)) -import System.Nix.Store.Remote.Types.ProtoVersion (ourProtoVersion) import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) +import qualified Data.Some +import qualified Data.Text +import qualified Data.Text.IO +import qualified System.Timeout +import qualified Network.Socket.ByteString -type WorkerHelper m = forall a. StoreRequest a -> m a +type WorkerHelper m + = forall a + . ( Show a + , StoreReply a + ) + => RemoteStoreT m a + -> Run m a + +chatty :: Bool +chatty = False + +dbg :: MonadIO m => Text -> m () +dbg = when chatty . liftIO . Data.Text.IO.putStrLn -- | Run an emulated nix daemon on given socket address. -- The deamon will close when the continuation returns. -runDaemonSocket +runProxyDaemon :: forall m a . ( MonadIO m , MonadConc m - , MonadError RemoteStoreError m - , MonadReader StoreConfig m ) - => StoreDir - -> WorkerHelper m + => WorkerHelper m + -> RemoteStoreT m () -> Socket -> m a -> m a -runDaemonSocket sd workerHelper lsock k = do +runProxyDaemon workerHelper postGreet lsock k = do liftIO $ listen lsock maxListenQueue - liftIO $ Data.Text.IO.putStrLn "listening" + dbg "listening" let listener :: m Void listener = do (sock, _) <- liftIO $ accept lsock - liftIO $ Data.Text.IO.putStrLn "accepting" - - let preStoreConfig = PreStoreConfig - { preStoreConfig_socket = sock - , preStoreConfig_dir = sd - } + dbg "accepting" -- TODO: this, but without the space leak - fmap fst $ concurrently listener $ processConnection workerHelper preStoreConfig + fmap fst + $ concurrently listener + $ processConnection workerHelper postGreet sock either absurd id <$> race listener k @@ -71,59 +83,128 @@ runDaemonSocket sd workerHelper lsock k = do -- -- this function should take care to not throw errors from client connections. processConnection - :: ( MonadIO m - , MonadError RemoteStoreError m - , MonadReader StoreConfig m - ) + :: forall m + . MonadIO m => WorkerHelper m - -> PreStoreConfig + -> RemoteStoreT m () + -> Socket -> m () -processConnection workerHelper preStoreConfig = do - ~() <- void $ runRemoteStoreT preStoreConfig $ do +processConnection workerHelper postGreet sock = do + ~() <- void $ runRemoteStoreT sock $ do ServerHandshakeOutput{..} <- greet ServerHandshakeInput { serverHandshakeInputNixVersion = "nixVersion (hnix-store-remote)" - , serverHandshakeInputOurVersion= ourProtoVersion + , serverHandshakeInputOurVersion = def , serverHandshakeInputTrust = Nothing } - mapStoreConfig - (preStoreConfigToStoreConfig - serverHandshakeOutputLeastCommonVersion) - $ do + setProtoVersion serverHandshakeOutputLeastCommonVersion - tunnelLogger <- liftIO $ newTunnelLogger - -- Send startup error messages to the client. - startWork tunnelLogger + tunnelLogger <- liftIO $ newTunnelLogger + -- Send startup error messages to the client. + startWork tunnelLogger - -- TODO: do we need auth at all? probably? - -- If we can't accept clientVersion, then throw an error *here* (not above). - --authHook(*store); - stopWork tunnelLogger + -- TODO: do we need auth at all? probably? + -- If we can't accept clientVersion, then throw an error *here* (not above). + --authHook(*store); + stopWork tunnelLogger - -- Process client requests. - let loop = do - someReq <- - sockGetS - $ mapErrorS - RemoteStoreError_SerializerRequest - storeRequest + -- so we can set store dir + postGreet - lift $ performOp' workerHelper tunnelLogger someReq - loop - loop + let perform + :: ( Show a + , StoreReply a + ) + => StoreRequest a + -> RemoteStoreT m () + perform req = do - liftIO $ Data.Text.IO.putStrLn "daemon connection done" - liftIO $ close $ preStoreConfig_socket preStoreConfig + special <- case req of + AddToStore {} -> do + -- This is a hack (but a pretty neat and fast one!) + -- it should parse nad stream NAR instead + let proxyNarSource :: NarSource IO + proxyNarSource f = + liftIO + (System.Timeout.timeout + 1000000 + (Network.Socket.ByteString.recv sock 8) + ) + >>= \case + Nothing -> pure () + Just x -> f x >> proxyNarSource f + + pure $ setNarSource proxyNarSource + _ -> pure $ pure () + + res <- + bracketLogger + tunnelLogger + $ lift + $ workerHelper + $ special >> doReq req + + case fst res of + Left e -> throwError e + Right reply -> + sockPutS + (mapErrorS + RemoteStoreError_SerializerReply + $ getReplyS + ) + reply + + -- Process client requests. + let loop = do + someReq <- + sockGetS + $ mapErrorS + RemoteStoreError_SerializerRequest + storeRequest + + -- have to be explicit here + -- because otherwise GHC can't conjure Show a, StoreReply a + -- out of thin air + () <- Data.Some.withSome someReq $ \case + r@AddToStore {} -> perform r + r@AddTextToStore {} -> perform r + r@AddSignatures {} -> perform r + r@AddTempRoot {} -> perform r + r@AddIndirectRoot {} -> perform r + r@BuildDerivation {} -> perform r + r@BuildPaths {} -> perform r + r@CollectGarbage {} -> perform r + r@EnsurePath {} -> perform r + r@FindRoots {} -> perform r + r@IsValidPath {} -> perform r + r@QueryValidPaths {} -> perform r + r@QueryAllValidPaths {} -> perform r + r@QuerySubstitutablePaths {} -> perform r + r@QueryPathInfo {} -> perform r + r@QueryReferrers {} -> perform r + r@QueryValidDerivers {} -> perform r + r@QueryDerivationOutputs {} -> perform r + r@QueryDerivationOutputNames {} -> perform r + r@QueryPathFromHashPart {} -> perform r + r@QueryMissing {} -> perform r + r@OptimiseStore {} -> perform r + r@SyncWithGC {} -> perform r + r@VerifyStore {} -> perform r + loop + loop + + dbg "daemon connection done" + liftIO $ close sock where -- Exchange the greeting. greet :: MonadIO m => ServerHandshakeInput - -> RemoteStoreT PreStoreConfig m ServerHandshakeOutput + -> RemoteStoreT m ServerHandshakeOutput greet ServerHandshakeInput{..} = do magic <- sockGetS @@ -131,7 +212,6 @@ processConnection workerHelper preStoreConfig = do RemoteStoreError_SerializerHandshake workerMagic - liftIO $ print ("magic" :: Text, magic) when (magic /= WorkerMagic_One) $ throwError $ RemoteStoreError_WorkerException @@ -148,9 +228,7 @@ processConnection workerHelper preStoreConfig = do clientVersion <- sockGetS protoVersion - let leastCommonVersion = min clientVersion ourProtoVersion - - liftIO $ print ("Versions client, min" :: Text, clientVersion, leastCommonVersion) + let leastCommonVersion = min clientVersion serverHandshakeInputOurVersion when (clientVersion < ProtoVersion 1 10) $ throwError @@ -189,57 +267,13 @@ processConnection workerHelper preStoreConfig = do , serverHandshakeOutputClientVersion = clientVersion } -simpleOp - :: ( MonadIO m - , HasStoreSocket r - , HasProtoVersion r - , MonadError RemoteStoreError m - , MonadReader r m - ) - => (StoreRequest () -> m ()) - -> TunnelLogger r - -> m (StoreRequest ()) - -> m () -simpleOp workerHelper tunnelLogger m = do - req <- m - bracketLogger tunnelLogger $ workerHelper req - sockPutS - (mapErrorS - RemoteStoreError_SerializerPut - bool - ) - True - -simpleOpRet - :: ( MonadIO m - , HasStoreSocket r - , HasProtoVersion r - , MonadError RemoteStoreError m - , MonadReader r m - ) - => (StoreRequest a -> m a) - -> TunnelLogger r - -> NixSerializer r SError a - -> m (StoreRequest a) - -> m () -simpleOpRet workerHelper tunnelLogger s m = do - req <- m - resp <- bracketLogger tunnelLogger $ workerHelper req - sockPutS - (mapErrorS - RemoteStoreError_SerializerPut - s - ) - resp +{-# WARNING _unimplemented "not yet implemented" #-} +_unimplemented :: RemoteStoreError +_unimplemented = RemoteStoreError_WorkerException $ WorkerException_Error $ WorkerError_NotYetImplemented bracketLogger - :: ( MonadIO m - , HasStoreSocket r - , HasProtoVersion r - , MonadReader r m - , MonadError RemoteStoreError m - ) - => TunnelLogger r + :: MonadRemoteStore m + => TunnelLogger -> m a -> m a bracketLogger tunnelLogger m = do @@ -248,81 +282,43 @@ bracketLogger tunnelLogger m = do stopWork tunnelLogger pure a -{-# WARNING unimplemented "not yet implemented" #-} -unimplemented :: WorkerException -unimplemented = WorkerException_Error $ WorkerError_NotYetImplemented - -performOp' - :: forall m - . ( MonadIO m - , MonadError RemoteStoreError m - , MonadReader StoreConfig m - ) - => WorkerHelper m - -> TunnelLogger StoreConfig - -> Some StoreRequest - -> m () -performOp' workerHelper tunnelLogger op = do - let _simpleOp' = simpleOp workerHelper tunnelLogger - let simpleOpRet' - :: NixSerializer StoreConfig SError a - -> m (StoreRequest a) - -> m () - simpleOpRet' = simpleOpRet workerHelper tunnelLogger - - case op of - Some (IsValidPath path) -> simpleOpRet' bool $ do - pure $ R.IsValidPath path - - _ -> undefined - --- -data TunnelLogger r = TunnelLogger - { _tunnelLogger_state :: IORef (TunnelLoggerState r) +data TunnelLogger = TunnelLogger + { _tunnelLogger_state :: IORef TunnelLoggerState } -data TunnelLoggerState r = TunnelLoggerState +data TunnelLoggerState = TunnelLoggerState { _tunnelLoggerState_canSendStderr :: Bool , _tunnelLoggerState_pendingMsgs :: [Logger] } -newTunnelLogger :: IO (TunnelLogger r) +newTunnelLogger :: IO TunnelLogger newTunnelLogger = TunnelLogger <$> newIORef (TunnelLoggerState False []) enqueueMsg - :: ( MonadIO m - , MonadReader r m + :: ( MonadRemoteStore m , MonadError LoggerSError m - , HasProtoVersion r - , HasStoreSocket r ) - => TunnelLogger r + => TunnelLogger -> Logger -> m () enqueueMsg x l = updateLogger x $ \st@(TunnelLoggerState c p) -> case c of True -> (st, sockPutS logger l) False -> (TunnelLoggerState c (l:p), pure ()) -log - :: ( MonadIO m - , MonadReader r m - , HasStoreSocket r +_log + :: ( MonadRemoteStore m , MonadError LoggerSError m - , HasProtoVersion r ) - => TunnelLogger r + => TunnelLogger -> Text -> m () -log l s = enqueueMsg l (Logger_Next s) +_log l s = enqueueMsg l (Logger_Next s) startWork - :: (MonadIO m, MonadReader r m, HasStoreSocket r - - , MonadError RemoteStoreError m - , HasProtoVersion r - ) - => TunnelLogger r + :: MonadRemoteStore m + => TunnelLogger -> m () startWork x = updateLogger x $ \(TunnelLoggerState _ p) -> (,) (TunnelLoggerState True []) $ @@ -330,12 +326,8 @@ startWork x = updateLogger x $ \(TunnelLoggerState _ p) -> (,) where logger' = mapErrorS RemoteStoreError_SerializerLogger logger stopWork - :: (MonadIO m, MonadReader r m, HasStoreSocket r - - , MonadError RemoteStoreError m - , HasProtoVersion r - ) - => TunnelLogger r + :: MonadRemoteStore m + => TunnelLogger -> m () stopWork x = updateLogger x $ \_ -> (,) (TunnelLoggerState False []) @@ -348,27 +340,24 @@ stopWork x = updateLogger x $ \_ -> (,) -- -- Unlike 'stopWork', this function may be called at any time to (try) to end a -- session with an error. -stopWorkOnError - :: (MonadIO m, MonadReader r m, HasStoreSocket r, HasProtoVersion r - - , MonadError RemoteStoreError m - ) - => TunnelLogger r +_stopWorkOnError + :: MonadRemoteStore m + => TunnelLogger -> ErrorInfo -> m Bool -stopWorkOnError x ex = updateLogger x $ \st -> +_stopWorkOnError x ex = updateLogger x $ \st -> case _tunnelLoggerState_canSendStderr st of False -> (st, pure False) True -> (,) (TunnelLoggerState False []) $ do - asks hasProtoVersion >>= \pv -> if protoVersion_minor pv >= 26 + getProtoVersion >>= \pv -> if protoVersion_minor pv >= 26 then sockPutS logger' (Logger_Error (Right ex)) else sockPutS logger' (Logger_Error (Left (BasicError 0 (Data.Text.pack $ show ex)))) pure True where logger' = mapErrorS RemoteStoreError_SerializerLogger logger updateLogger - :: (MonadIO m, MonadReader r m, HasStoreSocket r) - => TunnelLogger r - -> (TunnelLoggerState r -> (TunnelLoggerState r, m a)) + :: MonadRemoteStore m + => TunnelLogger + -> (TunnelLoggerState -> (TunnelLoggerState, m a)) -> m a updateLogger x = join . liftIO . atomicModifyIORef (_tunnelLogger_state x) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs index ac76f80..8c32152 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs @@ -2,14 +2,13 @@ module System.Nix.Store.Remote.Socket where import Control.Monad.Except (MonadError, throwError) import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Reader (MonadReader, ask, asks) import Data.ByteString (ByteString) import Data.Serialize.Get (Get, Result(..)) import Data.Serialize.Put (Put, runPut) import Network.Socket.ByteString (recv, sendAll) -import System.Nix.Store.Remote.MonadStore (MonadRemoteStoreR, RemoteStoreError(..)) +import System.Nix.Store.Remote.MonadStore (MonadRemoteStore(..), RemoteStoreError(..)) import System.Nix.Store.Remote.Serializer (NixSerializer, runP, runSerialT) -import System.Nix.Store.Remote.Types (HasStoreSocket(..)) +import System.Nix.Store.Remote.Types (ProtoStoreConfig) import qualified Control.Exception import qualified Data.ByteString @@ -47,14 +46,10 @@ genericIncremental getsome parser = do leftover sockGet8 - :: ( MonadIO m - , MonadError RemoteStoreError m - , MonadReader r m - , HasStoreSocket r - ) + :: MonadRemoteStore m => m ByteString sockGet8 = do - soc <- asks hasStoreSocket + soc <- getStoreSocket eresult <- liftIO $ Control.Exception.try $ recv soc 8 case eresult of Left e -> @@ -67,46 +62,39 @@ sockGet8 = do pure result sockPut - :: ( MonadRemoteStoreR r m - , HasStoreSocket r - ) + :: MonadRemoteStore m => Put -> m () sockPut p = do - soc <- asks hasStoreSocket + soc <- getStoreSocket liftIO $ sendAll soc $ runPut p sockPutS - :: ( MonadReader r m + :: ( MonadRemoteStore m , MonadError e m - , MonadIO m - , HasStoreSocket r ) - => NixSerializer r e a + => NixSerializer ProtoStoreConfig e a -> a -> m () sockPutS s a = do - r <- ask - case runP s r a of - Right x -> liftIO $ sendAll (hasStoreSocket r) x + cfg <- getConfig + sock <- getStoreSocket + case runP s cfg a of + Right x -> liftIO $ sendAll sock x Left e -> throwError e sockGetS - :: forall r e m a - . ( HasStoreSocket r - , MonadError RemoteStoreError m + :: ( MonadRemoteStore m , MonadError e m - , MonadReader r m - , MonadIO m , Show a , Show e ) - => NixSerializer r e a + => NixSerializer ProtoStoreConfig e a -> m a sockGetS s = do - r <- ask + cfg <- getConfig res <- genericIncremental sockGet8 - $ runSerialT r $ Data.Serializer.getS s + $ runSerialT cfg $ Data.Serializer.getS s case res of Right x -> pure x diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs index 3f3fa90..b8ef2e3 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs @@ -19,7 +19,7 @@ data ClientHandshakeInput = ClientHandshakeInput data ClientHandshakeOutput = ClientHandshakeOutput { clientHandshakeOutputNixVersion :: Maybe Text -- ^ Textual version, since 1.33 , clientHandshakeOutputTrust :: Maybe TrustedFlag -- ^ Whether remote side trusts us - , clientHandshakeOutputLeastCommonVerison :: ProtoVersion -- ^ Minimum protocol version supported by both sides + , clientHandshakeOutputLeastCommonVersion :: ProtoVersion -- ^ Minimum protocol version supported by both sides , clientHandshakeOutputServerVersion :: ProtoVersion -- ^ Protocol version supported by the server } deriving (Eq, Generic, Ord, Show) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs index 766a83f..484ba41 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs @@ -1,11 +1,11 @@ module System.Nix.Store.Remote.Types.ProtoVersion ( ProtoVersion(..) , HasProtoVersion(..) - , ourProtoVersion ) where +import Data.Default.Class (Default(def)) import Data.Word (Word8, Word16) -import GHC.Generics +import GHC.Generics (Generic) data ProtoVersion = ProtoVersion { protoVersion_major :: Word16 @@ -13,15 +13,15 @@ data ProtoVersion = ProtoVersion } deriving (Eq, Generic, Ord, Show) +-- | The protocol version we support +instance Default ProtoVersion where + def = ProtoVersion + { protoVersion_major = 1 + , protoVersion_minor = 24 + } + class HasProtoVersion r where hasProtoVersion :: r -> ProtoVersion instance HasProtoVersion ProtoVersion where hasProtoVersion = id - --- | The protocol version we support -ourProtoVersion :: ProtoVersion -ourProtoVersion = ProtoVersion - { protoVersion_major = 1 - , protoVersion_minor = 24 - } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs index 4735fa8..86e71b4 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs @@ -1,72 +1,61 @@ {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module System.Nix.Store.Remote.Types.StoreConfig - ( PreStoreConfig(..) - , StoreConfig(..) - , TestStoreConfig(..) + ( ProtoStoreConfig(..) + , StoreSocketPath(..) + , StoreTCP(..) + , StoreConnection(..) , HasStoreSocket(..) - , preStoreConfigToStoreConfig ) where +import Data.Default.Class (Default(def)) +import Data.String (IsString) import GHC.Generics (Generic) import Network.Socket (Socket) import System.Nix.StorePath (HasStoreDir(..), StoreDir) import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion) -data PreStoreConfig = PreStoreConfig - { preStoreConfig_dir :: StoreDir - , preStoreConfig_socket :: Socket - } - -instance HasStoreDir PreStoreConfig where - hasStoreDir = preStoreConfig_dir - class HasStoreSocket r where hasStoreSocket :: r -> Socket instance HasStoreSocket Socket where hasStoreSocket = id -instance HasStoreSocket PreStoreConfig where - hasStoreSocket = preStoreConfig_socket +data ProtoStoreConfig = ProtoStoreConfig + { protoStoreConfigDir :: StoreDir + , protoStoreConfigProtoVersion :: ProtoVersion + } deriving (Eq, Generic, Ord, Show) -data StoreConfig = StoreConfig - { storeConfig_dir :: StoreDir - , storeConfig_protoVersion :: ProtoVersion - , storeConfig_socket :: Socket - } +instance Default ProtoStoreConfig where + def = ProtoStoreConfig def def instance HasStoreDir StoreDir where hasStoreDir = id -instance HasStoreDir StoreConfig where - hasStoreDir = storeConfig_dir +instance HasStoreDir ProtoStoreConfig where + hasStoreDir = protoStoreConfigDir -instance HasProtoVersion StoreConfig where - hasProtoVersion = storeConfig_protoVersion +instance HasProtoVersion ProtoStoreConfig where + hasProtoVersion = protoStoreConfigProtoVersion -instance HasStoreSocket StoreConfig where - hasStoreSocket = storeConfig_socket +newtype StoreSocketPath = StoreSocketPath + { unStoreSocketPath :: FilePath + } + deriving newtype (IsString) + deriving stock (Eq, Generic, Ord, Show) -data TestStoreConfig = TestStoreConfig - { testStoreConfig_dir :: StoreDir - , testStoreConfig_protoVersion :: ProtoVersion +instance Default StoreSocketPath where + def = StoreSocketPath "/nix/var/nix/daemon-socket/socket" + +data StoreTCP = StoreTCP + { storeTCPHost :: String + , storeTCPPort :: Int } deriving (Eq, Generic, Ord, Show) -instance HasProtoVersion TestStoreConfig where - hasProtoVersion = testStoreConfig_protoVersion +data StoreConnection + = StoreConnection_Socket StoreSocketPath + | StoreConnection_TCP StoreTCP + deriving (Eq, Generic, Ord, Show) -instance HasStoreDir TestStoreConfig where - hasStoreDir = testStoreConfig_dir - --- | Convert @PreStoreConfig@ to @StoreConfig@ --- adding @ProtoVersion@ to latter -preStoreConfigToStoreConfig - :: ProtoVersion - -> PreStoreConfig - -> StoreConfig -preStoreConfigToStoreConfig pv PreStoreConfig{..} = - StoreConfig - { storeConfig_dir = preStoreConfig_dir - , storeConfig_protoVersion = pv - , storeConfig_socket = preStoreConfig_socket - } +instance Default StoreConnection where + def = StoreConnection_Socket def diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs index c6a475d..1f254c3 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs @@ -5,12 +5,12 @@ module System.Nix.Store.Remote.Types.StoreReply import Data.HashSet (HashSet) import Data.Map (Map) import System.Nix.Build (BuildResult) -import System.Nix.StorePath (HasStoreDir(..), StorePath, StorePathName) +import System.Nix.StorePath (StorePath, StorePathName) import System.Nix.StorePath.Metadata (Metadata) import System.Nix.Store.Remote.Serializer import System.Nix.Store.Remote.Types.GC (GCResult, GCRoot) import System.Nix.Store.Remote.Types.Query.Missing (Missing) -import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion) +import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig) -- | Get @NixSerializer@ for some type @a@ -- This could also be generalized for every type @@ -18,11 +18,7 @@ import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion) -- this for replies and it would make look serializers -- quite hodor, like @a <- getS get; b <- getS get@ class StoreReply a where - getReplyS - :: ( HasStoreDir r - , HasProtoVersion r - ) - => NixSerializer r ReplySError a + getReplyS :: NixSerializer ProtoStoreConfig ReplySError a instance StoreReply () where getReplyS = opSuccess diff --git a/hnix-store-remote/tests-io/NixDaemonSpec.hs b/hnix-store-remote/tests-io/NixDaemonSpec.hs index 3e8aec1..ee2e4e7 100644 --- a/hnix-store-remote/tests-io/NixDaemonSpec.hs +++ b/hnix-store-remote/tests-io/NixDaemonSpec.hs @@ -5,12 +5,15 @@ module NixDaemonSpec , spec ) where +import Control.Exception (catch, SomeException) import Control.Monad (forM_, unless, void) -import Control.Monad.IO.Class (liftIO) +import Control.Monad.Catch (MonadMask) +import Control.Monad.Conc.Class (MonadConc) +import Control.Monad.IO.Class (MonadIO, liftIO) import Crypto.Hash (SHA256) import Data.Some (Some(Some)) import Data.Text (Text) -import Test.Hspec (Spec, SpecWith, around, describe, context) +import Test.Hspec (ActionWith, Spec, SpecWith, around, describe, context) import Test.Hspec.Expectations.Lifted import Test.Hspec.Nix (forceRight) import System.FilePath (()) @@ -21,7 +24,7 @@ import System.Nix.DerivedPath (DerivedPath(..)) import System.Nix.StorePath (StoreDir(..), StorePath) import System.Nix.StorePath.Metadata (Metadata(..)) import System.Nix.Store.Remote -import System.Nix.Store.Remote.MonadStore (MonadRemoteStore) +import System.Nix.Store.Remote.Server (WorkerHelper) import System.Process (CreateProcess(..), ProcessHandle) import qualified Control.Concurrent import qualified Control.Exception @@ -38,21 +41,19 @@ import qualified System.IO.Temp import qualified System.Linux.Namespaces import qualified System.Nix.StorePath import qualified System.Nix.Nar -import qualified System.Nix.Store.Remote.MonadStore import qualified System.Posix.User import qualified System.Process import qualified Test.Hspec createProcessEnv :: FilePath - -> String - -> [String] + -> CreateProcess -> IO ProcessHandle -createProcessEnv fp proc args = do +createProcessEnv fp cp = do mPath <- System.Environment.lookupEnv "PATH" (_, _, _, ph) <- - System.Process.createProcess (System.Process.proc proc args) + System.Process.createProcess cp { cwd = Just fp , env = Just $ mockedEnv mPath fp } @@ -106,19 +107,19 @@ error: changing ownership of path '/run/user/1000/test-nix-store-06b0d249e561612 -} startDaemon - :: FilePath - -> IO (ProcessHandle, MonadStore a -> Run IO a) + :: FilePath -- ^ Temporary directory + -> IO (ProcessHandle, StoreConnection) startDaemon fp = do writeConf (fp "etc" "nix.conf") - procHandle <- createProcessEnv fp "nix-daemon" [] + procHandle <- + createProcessEnv + fp + $ System.Process.proc "nix-daemon" mempty + waitSocket sockFp 30 pure ( procHandle - , runStoreOpts - sockFp - (StoreDir - $ Data.ByteString.Char8.pack - $ fp "store" - ) + , StoreConnection_Socket + $ StoreSocketPath sockFp ) where sockFp = fp "var/nix/daemon-socket/socket" @@ -146,10 +147,10 @@ enterNamespaces = do [ GroupMapping 0 gid 1 ] True -withNixDaemon - :: ((MonadStore a -> Run IO a) -> IO a) +withNixDaemon' + :: (FilePath -> StoreDir -> StoreConnection -> IO a) -> IO a -withNixDaemon action = +withNixDaemon' action = System.IO.Temp.withSystemTempDirectory "test-nix-store" $ \path -> do mapM_ (System.Directory.createDirectory . snd) @@ -157,17 +158,69 @@ withNixDaemon action = ((/= "NIX_REMOTE") . fst) $ mockedEnv Nothing path) - ini <- createProcessEnv path "nix-store" ["--init"] + ini <- + createProcessEnv + path + $ System.Process.shell + -- see long note above @startDaemon@ + "nix-store --init 2>&1 | grep -v 'error: changing ownership'" + void $ System.Process.waitForProcess ini writeFile (path "dummy") "Hello World" System.Directory.setCurrentDirectory path + let storeDir = + StoreDir + $ Data.ByteString.Char8.pack + $ path "store" Control.Exception.bracket (startDaemon path) (System.Process.terminateProcess . fst) - (action . snd) + (action path storeDir . snd) + +withNixDaemon + :: ( MonadIO m + , MonadMask m + ) + => ((RemoteStoreT m a -> Run m a) -> IO a) + -> IO a +withNixDaemon action = + withNixDaemon' $ \_tmpPath storeDir storeConn -> + action $ \(mstore :: RemoteStoreT m a) -> + runStoreConnection storeConn + ( setStoreDir storeDir + >> mstore + ) + +withManInTheMiddleNixDaemon + :: forall m a + . ( MonadIO m + , MonadMask m + , MonadConc m + ) + => ((RemoteStoreT m a -> Run m a) -> IO a) + -> IO a +withManInTheMiddleNixDaemon action = + withNixDaemon' $ \tmpPath storeDir storeConn -> + let + sockFp2 = tmpPath "var/nix/daemon-socket/socket2" + storeConn2 = StoreConnection_Socket $ StoreSocketPath sockFp2 + + handler :: WorkerHelper m + handler = + runStoreConnection storeConn + . (setStoreDir storeDir >>) + + in action $ \(mstore :: RemoteStoreT m a) -> + runDaemonConnection handler + (setStoreDir storeDir) + storeConn2 + $ runStoreConnection storeConn2 + ( setStoreDir storeDir + >> mstore + ) checks :: ( Show a @@ -211,8 +264,9 @@ itLefts itLefts name action = it name action Data.Either.isLeft withPath - :: (StorePath -> MonadStore a) - -> MonadStore a + :: MonadRemoteStore m + => (StorePath -> m a) + -> m a withPath action = do path <- addTextToStore @@ -225,7 +279,7 @@ withPath action = do action path -- | dummy path, adds /dummy with "Hello World" contents -dummy :: MonadStore StorePath +dummy :: MonadRemoteStore m => m StorePath dummy = do addToStore (forceRight $ System.Nix.StorePath.mkStorePathName "dummy") @@ -250,7 +304,10 @@ _withBuilder _withBuilder action = do path <- addTextToStore - (StoreText (forceRight $ System.Nix.StorePath.mkStorePathName "builder") builderSh) + (StoreText + (forceRight $ System.Nix.StorePath.mkStorePathName "builder") + builderSh + ) mempty RepairMode_DontRepair action path @@ -259,139 +316,175 @@ builderSh :: Text builderSh = "declare -xpexport > $out" spec :: Spec -spec = around withNixDaemon $ +spec = do + describe "Remote store protocol" $ do + describe "Direct" + $ makeProtoSpec + withNixDaemon + SpecFlavor_Direct + describe "MITM" + $ makeProtoSpec + withManInTheMiddleNixDaemon + SpecFlavor_MITM - describe "store" $ do +data SpecFlavor + = SpecFlavor_Direct + | SpecFlavor_MITM + deriving (Eq, Ord, Show) - context "syncWithGC" $ - itRights "syncs with garbage collector" syncWithGC +makeProtoSpec + :: (ActionWith + (RemoteStoreT IO () -> Run IO ()) + -> IO () + ) + -> SpecFlavor + -> Spec +makeProtoSpec f flavor = around f $ do + context "syncWithGC" $ + itRights "syncs with garbage collector" syncWithGC - context "verifyStore" $ do - itRights "check=False repair=False" $ - verifyStore - CheckMode_DontCheck - RepairMode_DontRepair - `shouldReturn` False + context "verifyStore" $ do + itRights "check=False repair=False" $ + verifyStore + CheckMode_DontCheck + RepairMode_DontRepair + `shouldReturn` False - itRights "check=True repair=False" $ - verifyStore - CheckMode_DoCheck - RepairMode_DontRepair - `shouldReturn` False + itRights "check=True repair=False" $ + verifyStore + CheckMode_DoCheck + RepairMode_DontRepair + `shouldReturn` False - --privileged - itRights "check=True repair=True" $ - verifyStore - CheckMode_DoCheck - RepairMode_DoRepair - `shouldReturn` False + --privileged + itRights "check=True repair=True" $ + verifyStore + CheckMode_DoCheck + RepairMode_DoRepair + `shouldReturn` False - context "addTextToStore" $ - itRights "adds text to store" $ withPath pure + context "addTextToStore" $ + itRights "adds text to store" $ withPath pure - context "isValidPath" $ do - itRights "validates path" $ withPath $ \path -> do - liftIO $ print path - isValidPath path `shouldReturn` True - itLefts "fails on invalid path" - $ System.Nix.Store.Remote.MonadStore.mapStoreConfig - (\sc -> sc { storeConfig_dir = StoreDir "/asdf" }) - $ isValidPath invalidPath + context "isValidPath" $ do + itRights "validates path" $ withPath $ \path -> do + isValidPath path `shouldReturn` True - context "queryAllValidPaths" $ do - itRights "empty query" queryAllValidPaths - itRights "non-empty query" $ withPath $ \path -> - queryAllValidPaths `shouldReturn` Data.HashSet.fromList [path] + itLefts "fails on invalid path" $ do + setStoreDir (StoreDir "/asdf") + isValidPath invalidPath - context "queryPathInfo" $ - itRights "queries path info" $ withPath $ \path -> do - meta <- queryPathInfo path - (metadataReferences <$> meta) `shouldBe` (Just mempty) + context "queryAllValidPaths" $ do + itRights "empty query" queryAllValidPaths + itRights "non-empty query" $ withPath $ \path -> + queryAllValidPaths `shouldReturn` Data.HashSet.fromList [path] - context "ensurePath" $ - itRights "simple ensure" $ withPath ensurePath + context "queryPathInfo" $ + itRights "queries path info" $ withPath $ \path -> do + meta <- queryPathInfo path + (metadataReferences <$> meta) `shouldBe` (Just mempty) - context "addTempRoot" $ - itRights "simple addition" $ withPath addTempRoot + context "ensurePath" $ + itRights "simple ensure" $ withPath ensurePath - context "addIndirectRoot" $ - itRights "simple addition" $ withPath addIndirectRoot + context "addTempRoot" $ + itRights "simple addition" $ withPath addTempRoot - let toDerivedPathSet p = Data.Set.fromList [DerivedPath_Opaque p] + context "addIndirectRoot" $ + itRights "simple addition" $ withPath addIndirectRoot - context "buildPaths" $ do - itRights "build Normal" $ withPath $ \path -> do - buildPaths (toDerivedPathSet path) BuildMode_Normal + let toDerivedPathSet p = Data.Set.fromList [DerivedPath_Opaque p] - itRights "build Check" $ withPath $ \path -> do - buildPaths (toDerivedPathSet path) BuildMode_Check + context "buildPaths" $ do + itRights "build Normal" $ withPath $ \path -> do + buildPaths (toDerivedPathSet path) BuildMode_Normal - itLefts "build Repair" $ withPath $ \path -> do - buildPaths (toDerivedPathSet path) BuildMode_Repair + itRights "build Check" $ withPath $ \path -> do + buildPaths (toDerivedPathSet path) BuildMode_Check - context "roots" $ context "findRoots" $ do - itRights "empty roots" (findRoots `shouldReturn` mempty) + itLefts "build Repair" $ withPath $ \path -> do + buildPaths (toDerivedPathSet path) BuildMode_Repair - itRights "path added as a temp root" $ withPath $ \_ -> do - roots <- findRoots - roots `shouldSatisfy` ((== 1) . Data.Map.size) + context "roots" $ context "findRoots" $ do + itRights "empty roots" (findRoots `shouldReturn` mempty) - context "optimiseStore" $ itRights "optimises" optimiseStore + itRights "path added as a temp root" $ withPath $ \_ -> do + let expectRoots = + if flavor == SpecFlavor_MITM + then 0 -- nested client closes its connection so temp root gets removed + else 1 + roots <- findRoots + roots `shouldSatisfy` ((== expectRoots) . Data.Map.size) - context "queryMissing" $ - itRights "queries" $ withPath $ \path -> do - queryMissing (toDerivedPathSet path) - `shouldReturn` - Missing - { missingWillBuild = mempty - , missingWillSubstitute = mempty - , missingUnknownPaths = mempty - , missingDownloadSize = 0 - , missingNarSize = 0 - } + itRights "indirect root" $ withPath $ \path -> do + let expectRoots = + if flavor == SpecFlavor_MITM + then 1 -- nested client closes its connection so temp root gets removed + else 2 + addIndirectRoot path + roots <- findRoots + roots `shouldSatisfy` ((== expectRoots) . Data.Map.size) - context "addToStore" $ - itRights "adds file to store" $ do - fp <- - liftIO - $ System.IO.Temp.writeSystemTempFile - "addition" - "yolo" + context "optimiseStore" $ itRights "optimises" optimiseStore - addToStore - (forceRight $ System.Nix.StorePath.mkStorePathName "tmp-addition") - (System.Nix.Nar.dumpPath fp) - FileIngestionMethod_Flat - (Some HashAlgo_SHA256) - RepairMode_DontRepair + context "queryMissing" $ + itRights "queries" $ withPath $ \path -> do + queryMissing (toDerivedPathSet path) + `shouldReturn` + Missing + { missingWillBuild = mempty + , missingWillSubstitute = mempty + , missingUnknownPaths = mempty + , missingDownloadSize = 0 + , missingNarSize = 0 + } - context "with dummy" $ do - itRights "adds dummy" dummy + context "addToStore" $ + itRights "adds file to store" $ do + fp <- + liftIO + $ System.IO.Temp.writeSystemTempFile + "addition" + "yolo" - itRights "valid dummy" $ do - path <- dummy - isValidPath path `shouldReturn` True + addToStore + (forceRight $ System.Nix.StorePath.mkStorePathName "tmp-addition") + (System.Nix.Nar.dumpPath fp) + FileIngestionMethod_Flat + (Some HashAlgo_SHA256) + RepairMode_DontRepair - context "collectGarbage" $ do - itRights "delete a specific path from the store" $ withPath $ \path -> do - -- clear temp gc roots so the delete works. restarting the nix daemon should also do this... - storeDir <- getStoreDir - let tempRootsDir = Data.Text.unpack $ mconcat [ Data.Text.Encoding.decodeUtf8 (unStoreDir storeDir), "/../var/nix/temproots/" ] + context "with dummy" $ do + itRights "adds dummy" dummy + + itRights "valid dummy" $ do + path <- dummy + isValidPath path `shouldReturn` True + + context "collectGarbage" $ do + itRights "deletes a specific path from the store" $ withPath $ \path -> do + -- clear temp gc roots so the delete works. restarting the nix daemon should also do this... + storeDir <- getStoreDir + let tempRootsDir = Data.Text.unpack $ mconcat [ Data.Text.Encoding.decodeUtf8 (unStoreDir storeDir), "/../var/nix/temproots/" ] + liftIO $ do tempRootList <- - liftIO - $ System.Directory.listDirectory - tempRootsDir - liftIO $ forM_ tempRootList $ \entry -> do + System.Directory.listDirectory tempRootsDir + forM_ tempRootList $ \entry -> do System.Directory.removeFile $ mconcat [ tempRootsDir, "/", entry ] + -- for MITM, the temp root will get deleted + -- by the daemon as our nested client exists + -- but the listDirectory might still see it + -- causing TOC/TOU flakiness + `catch` (\(_e :: SomeException) -> pure ()) - GCResult{..} <- - collectGarbage - GCOptions - { gcOptionsOperation = GCAction_DeleteSpecific - , gcOptionsIgnoreLiveness = False - , gcOptionsPathsToDelete = Data.HashSet.fromList [path] - , gcOptionsMaxFreed = maxBound - } - gcResultDeletedPaths `shouldBe` Data.HashSet.fromList [path] - gcResultBytesFreed `shouldBe` 4 + GCResult{..} <- + collectGarbage + GCOptions + { gcOptionsOperation = GCAction_DeleteSpecific + , gcOptionsIgnoreLiveness = False + , gcOptionsPathsToDelete = Data.HashSet.fromList [path] + , gcOptionsMaxFreed = maxBound + } + gcResultDeletedPaths `shouldBe` Data.HashSet.fromList [path] + gcResultBytesFreed `shouldBe` 4 diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index 0fa2115..e229fff 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -17,7 +17,7 @@ import System.Nix.Store.Remote.Arbitrary () import System.Nix.Store.Remote.Serializer import System.Nix.Store.Remote.Types.Logger (Logger(..)) import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..)) -import System.Nix.Store.Remote.Types.StoreConfig (TestStoreConfig(..)) +import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig(..)) import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) -- | Test for roundtrip using @NixSerializer@ @@ -71,7 +71,7 @@ spec = parallel $ do prop "< 1.28" $ \sd -> forAll (arbitrary `suchThat` ((< 28) . protoVersion_minor)) $ \pv -> - roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd pv) + roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd pv) . (\x -> x { buildResultBuiltOutputs = Nothing }) . (\x -> x { buildResultTimesBuilt = Nothing , buildResultIsNonDeterministic = Nothing @@ -81,7 +81,7 @@ spec = parallel $ do ) prop "= 1.28" $ \sd -> - roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd (ProtoVersion 1 28)) + roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd (ProtoVersion 1 28)) . (\x -> x { buildResultTimesBuilt = Nothing , buildResultIsNonDeterministic = Nothing , buildResultStartTime = Nothing @@ -91,7 +91,7 @@ spec = parallel $ do prop "> 1.28" $ \sd -> forAll (arbitrary `suchThat` ((> 28) . protoVersion_minor)) $ \pv -> - roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd pv) + roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd pv) prop "StorePath" $ roundtripSReader @StoreDir storePath @@ -147,7 +147,7 @@ spec = parallel $ do prop "StoreRequest" $ \testStoreConfig -> forAll (arbitrary `suchThat` (restrictProtoVersion (hasProtoVersion testStoreConfig))) - $ roundtripSReader @TestStoreConfig storeRequest testStoreConfig + $ roundtripSReader @ProtoStoreConfig storeRequest testStoreConfig describe "StoreReply" $ do prop "()" $ roundtripS opSuccess