mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-08-17 22:00:43 +03:00
commit
21040fb589
@ -31,3 +31,4 @@ in order of appearance:
|
||||
+ Ryan Trinkle @ryantrinkle
|
||||
+ Travis Whitaker @TravisWhitaker
|
||||
+ Andrea Bedini @andreabedini
|
||||
+ Dan Bornside @danbornside
|
||||
|
@ -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 =
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
```
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
--
|
||||
|
@ -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
|
||||
}
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
}
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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
|
||||
}
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 <tmp>/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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user