mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-09-11 18:05:56 +03:00
commit
21040fb589
@ -31,3 +31,4 @@ in order of appearance:
|
|||||||
+ Ryan Trinkle @ryantrinkle
|
+ Ryan Trinkle @ryantrinkle
|
||||||
+ Travis Whitaker @TravisWhitaker
|
+ Travis Whitaker @TravisWhitaker
|
||||||
+ Andrea Bedini @andreabedini
|
+ Andrea Bedini @andreabedini
|
||||||
|
+ Dan Bornside @danbornside
|
||||||
|
@ -25,12 +25,17 @@ import qualified System.Nix.StorePath
|
|||||||
|
|
||||||
data OutputsSpec =
|
data OutputsSpec =
|
||||||
OutputsSpec_All
|
OutputsSpec_All
|
||||||
|
-- ^ Wildcard spec (^*) meaning all outputs
|
||||||
| OutputsSpec_Names (Set OutputName)
|
| OutputsSpec_Names (Set OutputName)
|
||||||
|
-- ^ Set of specific outputs
|
||||||
deriving (Eq, Generic, Ord, Show)
|
deriving (Eq, Generic, Ord, Show)
|
||||||
|
|
||||||
data DerivedPath =
|
data DerivedPath =
|
||||||
DerivedPath_Opaque StorePath
|
DerivedPath_Opaque StorePath
|
||||||
|
-- ^ Fully evaluated store path that can't be built
|
||||||
|
-- but can be fetched
|
||||||
| DerivedPath_Built StorePath OutputsSpec
|
| DerivedPath_Built StorePath OutputsSpec
|
||||||
|
-- ^ Derivation path and the outputs built from it
|
||||||
deriving (Eq, Generic, Ord, Show)
|
deriving (Eq, Generic, Ord, Show)
|
||||||
|
|
||||||
data ParseOutputsError =
|
data ParseOutputsError =
|
||||||
|
@ -8,6 +8,7 @@ module System.Nix.Realisation (
|
|||||||
, derivationOutputBuilder
|
, derivationOutputBuilder
|
||||||
, derivationOutputParser
|
, derivationOutputParser
|
||||||
, Realisation(..)
|
, Realisation(..)
|
||||||
|
, RealisationWithId(..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Crypto.Hash (Digest)
|
import Crypto.Hash (Digest)
|
||||||
@ -80,8 +81,7 @@ derivationOutputBuilder outputName DerivationOutput{..} =
|
|||||||
--
|
--
|
||||||
-- realisationId is ommited since it is a key
|
-- realisationId is ommited since it is a key
|
||||||
-- of type @DerivationOutput OutputName@ so
|
-- of type @DerivationOutput OutputName@ so
|
||||||
-- we will use a tuple like @(DerivationOutput OutputName, Realisation)@
|
-- we will use @RealisationWithId@ newtype
|
||||||
-- instead.
|
|
||||||
data Realisation = Realisation
|
data Realisation = Realisation
|
||||||
{ realisationOutPath :: StorePath
|
{ realisationOutPath :: StorePath
|
||||||
-- ^ Output path
|
-- ^ Output path
|
||||||
@ -90,3 +90,14 @@ data Realisation = Realisation
|
|||||||
, realisationDependencies :: Map (DerivationOutput OutputName) StorePath
|
, realisationDependencies :: Map (DerivationOutput OutputName) StorePath
|
||||||
-- ^ Dependent realisations required for this one to be valid
|
-- ^ Dependent realisations required for this one to be valid
|
||||||
} deriving (Eq, Generic, Ord, Show)
|
} 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 Deriving.Aeson
|
||||||
import System.Nix.Base (BaseEncoding(NixBase32))
|
import System.Nix.Base (BaseEncoding(NixBase32))
|
||||||
import System.Nix.OutputName (OutputName)
|
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.Signature (Signature)
|
||||||
import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, StorePathHashPart)
|
import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, StorePathHashPart)
|
||||||
|
|
||||||
@ -159,18 +159,18 @@ deriving
|
|||||||
instance FromJSON Realisation
|
instance FromJSON Realisation
|
||||||
|
|
||||||
-- For a keyed version of Realisation
|
-- For a keyed version of Realisation
|
||||||
-- we use (DerivationOutput OutputName, Realisation)
|
-- we use RealisationWithId (DerivationOutput OutputName, Realisation)
|
||||||
-- instead of Realisation.id :: (DerivationOutput OutputName)
|
-- instead of Realisation.id :: (DerivationOutput OutputName)
|
||||||
-- field.
|
-- field.
|
||||||
instance {-# OVERLAPPING #-} ToJSON (DerivationOutput OutputName, Realisation) where
|
instance ToJSON RealisationWithId where
|
||||||
toJSON (drvOut, r) =
|
toJSON (RealisationWithId (drvOut, r)) =
|
||||||
case toJSON r of
|
case toJSON r of
|
||||||
Object o -> Object $ Data.Aeson.KeyMap.insert "id" (toJSON drvOut) o
|
Object o -> Object $ Data.Aeson.KeyMap.insert "id" (toJSON drvOut) o
|
||||||
_ -> error "absurd"
|
_ -> error "absurd"
|
||||||
|
|
||||||
instance {-# OVERLAPPING #-} FromJSON (DerivationOutput OutputName, Realisation) where
|
instance FromJSON RealisationWithId where
|
||||||
parseJSON v@(Object o) = do
|
parseJSON v@(Object o) = do
|
||||||
r <- parseJSON @Realisation v
|
r <- parseJSON @Realisation v
|
||||||
drvOut <- o .: "id"
|
drvOut <- o .: "id"
|
||||||
pure (drvOut, r)
|
pure (RealisationWithId (drvOut, r))
|
||||||
parseJSON x = fail $ "Expected Object but got " ++ show x
|
parseJSON x = fail $ "Expected Object but got " ++ show x
|
||||||
|
@ -14,17 +14,14 @@ via `nix-daemon`.
|
|||||||
```haskell
|
```haskell
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
import Control.Monad (void)
|
|
||||||
import Control.Monad.IO.Class (liftIO)
|
|
||||||
import System.Nix.StorePath (mkStorePathName)
|
import System.Nix.StorePath (mkStorePathName)
|
||||||
import System.Nix.Store.Remote
|
import System.Nix.Store.Remote
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
void $ runStore $ do
|
runStore $ do
|
||||||
syncWithGC
|
syncWithGC
|
||||||
roots <- findRoots
|
roots <- findRoots
|
||||||
liftIO $ print roots
|
|
||||||
|
|
||||||
res <- case mkStorePathName "hnix-store" of
|
res <- case mkStorePathName "hnix-store" of
|
||||||
Left e -> error (show e)
|
Left e -> error (show e)
|
||||||
@ -33,5 +30,7 @@ main = do
|
|||||||
(StoreText name "Hello World!")
|
(StoreText name "Hello World!")
|
||||||
mempty
|
mempty
|
||||||
RepairMode_DontRepair
|
RepairMode_DontRepair
|
||||||
liftIO $ print res
|
|
||||||
|
pure (roots, res)
|
||||||
|
>>= print
|
||||||
```
|
```
|
||||||
|
@ -2,39 +2,23 @@
|
|||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Data.Default.Class (Default(def))
|
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
|
||||||
import qualified Data.Text.IO
|
|
||||||
import qualified Data.Attoparsec.Text
|
|
||||||
import qualified System.Environment
|
import qualified System.Environment
|
||||||
import qualified System.Nix.Build
|
import qualified System.Nix.Build
|
||||||
import qualified System.Nix.Derivation
|
|
||||||
import qualified System.Nix.StorePath
|
import qualified System.Nix.StorePath
|
||||||
import qualified System.Nix.Store.Remote
|
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 :: IO ()
|
||||||
main = System.Environment.getArgs >>= \case
|
main = System.Environment.getArgs >>= \case
|
||||||
[filename] -> do
|
[filename] -> do
|
||||||
case System.Nix.StorePath.parsePathFromText def (Data.Text.pack filename) of
|
case System.Nix.StorePath.parsePathFromText def (Data.Text.pack filename) of
|
||||||
Left e -> error $ show e
|
Left e -> error $ show e
|
||||||
Right p -> do
|
Right p -> do
|
||||||
d <- parseDerivation filename
|
|
||||||
out <-
|
out <-
|
||||||
System.Nix.Store.Remote.runStore
|
System.Nix.Store.Remote.runStore
|
||||||
$ System.Nix.Store.Remote.buildDerivation
|
$ System.Nix.Store.Remote.buildDerivation
|
||||||
p
|
p
|
||||||
d
|
|
||||||
System.Nix.Build.BuildMode_Normal
|
System.Nix.Build.BuildMode_Normal
|
||||||
print out
|
print out
|
||||||
_ -> error "No input derivation file"
|
_ -> error "No input derivation file"
|
||||||
|
@ -46,11 +46,6 @@ common commons
|
|||||||
, ViewPatterns
|
, ViewPatterns
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
common tests
|
|
||||||
import: commons
|
|
||||||
build-tool-depends:
|
|
||||||
tasty-discover:tasty-discover
|
|
||||||
|
|
||||||
flag io-testsuite
|
flag io-testsuite
|
||||||
default:
|
default:
|
||||||
False
|
False
|
||||||
@ -119,7 +114,9 @@ library
|
|||||||
, data-default-class
|
, data-default-class
|
||||||
, dependent-sum > 0.7
|
, dependent-sum > 0.7
|
||||||
, dependent-sum-template >= 0.2.0.1 && < 0.3
|
, dependent-sum-template >= 0.2.0.1 && < 0.3
|
||||||
|
-- , directory
|
||||||
, dlist >= 1.0
|
, dlist >= 1.0
|
||||||
|
, exceptions
|
||||||
, generic-arbitrary < 1.1
|
, generic-arbitrary < 1.1
|
||||||
, hashable
|
, hashable
|
||||||
, text
|
, text
|
||||||
@ -139,7 +136,6 @@ executable build-derivation
|
|||||||
buildable: False
|
buildable: False
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.12 && <5
|
base >=4.12 && <5
|
||||||
, attoparsec
|
|
||||||
, hnix-store-core
|
, hnix-store-core
|
||||||
, hnix-store-remote
|
, hnix-store-remote
|
||||||
, data-default-class
|
, data-default-class
|
||||||
@ -163,7 +159,7 @@ executable remote-readme
|
|||||||
ghc-options: -pgmL markdown-unlit -Wall
|
ghc-options: -pgmL markdown-unlit -Wall
|
||||||
|
|
||||||
test-suite remote
|
test-suite remote
|
||||||
import: tests
|
import: commons
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
main-is: Driver.hs
|
main-is: Driver.hs
|
||||||
hs-source-dirs: tests
|
hs-source-dirs: tests
|
||||||
@ -187,7 +183,7 @@ test-suite remote
|
|||||||
, QuickCheck
|
, QuickCheck
|
||||||
|
|
||||||
test-suite remote-io
|
test-suite remote-io
|
||||||
import: tests
|
import: commons
|
||||||
|
|
||||||
if !flag(io-testsuite) || os(darwin)
|
if !flag(io-testsuite) || os(darwin)
|
||||||
buildable: False
|
buildable: False
|
||||||
@ -206,9 +202,11 @@ test-suite remote-io
|
|||||||
, hnix-store-remote
|
, hnix-store-remote
|
||||||
, hnix-store-tests
|
, hnix-store-tests
|
||||||
, bytestring
|
, bytestring
|
||||||
|
, concurrency
|
||||||
, containers
|
, containers
|
||||||
, crypton
|
, crypton
|
||||||
, directory
|
, directory
|
||||||
|
, exceptions
|
||||||
, filepath
|
, filepath
|
||||||
, hspec
|
, hspec
|
||||||
, hspec-expectations-lifted
|
, hspec-expectations-lifted
|
||||||
|
@ -1,6 +1,8 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE Rank2Types #-}
|
||||||
|
|
||||||
module System.Nix.Store.Remote
|
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.Client
|
||||||
, module System.Nix.Store.Remote.MonadStore
|
, module System.Nix.Store.Remote.MonadStore
|
||||||
, module System.Nix.Store.Remote.Types
|
, module System.Nix.Store.Remote.Types
|
||||||
@ -8,79 +10,190 @@ module System.Nix.Store.Remote
|
|||||||
, MonadStore
|
, MonadStore
|
||||||
-- * Runners
|
-- * Runners
|
||||||
, runStore
|
, runStore
|
||||||
, runStoreOpts
|
, runStoreConnection
|
||||||
, runStoreOptsTCP
|
, runStoreSocket
|
||||||
|
-- ** Daemon
|
||||||
|
, runDaemon
|
||||||
|
, runDaemonConnection
|
||||||
|
, justdoit
|
||||||
) where
|
) 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 Data.Default.Class (Default(def))
|
||||||
import Network.Socket (Family, SockAddr(SockAddrUnix))
|
import Network.Socket (Family, SockAddr(SockAddrUnix))
|
||||||
import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))
|
import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))
|
||||||
import System.Nix.StorePath (StoreDir)
|
import System.Nix.Store.Remote.MonadStore
|
||||||
import System.Nix.Store.Remote.MonadStore (RemoteStoreT, getStoreDir, RemoteStoreError(RemoteStoreError_GetAddrInfoFailed))
|
( runRemoteStoreT
|
||||||
|
, MonadRemoteStore(..)
|
||||||
|
, RemoteStoreT
|
||||||
|
, RemoteStoreError(RemoteStoreError_GetAddrInfoFailed))
|
||||||
import System.Nix.Store.Remote.Client
|
import System.Nix.Store.Remote.Client
|
||||||
|
import System.Nix.Store.Remote.Server (WorkerHelper, runProxyDaemon)
|
||||||
import System.Nix.Store.Remote.Types
|
import System.Nix.Store.Remote.Types
|
||||||
|
|
||||||
import qualified Control.Exception
|
import qualified Control.Monad.Catch
|
||||||
import qualified Network.Socket
|
import qualified Network.Socket
|
||||||
|
-- see TODO bellow
|
||||||
|
--import qualified System.Directory
|
||||||
|
|
||||||
|
-- wip justdoit
|
||||||
|
import System.Nix.StorePath (StorePath)
|
||||||
|
import qualified System.Nix.StorePath
|
||||||
|
|
||||||
-- * Compat
|
-- * Compat
|
||||||
|
|
||||||
type MonadStore = RemoteStoreT StoreConfig IO
|
type MonadStore = RemoteStoreT IO
|
||||||
|
|
||||||
-- * Runners
|
-- * Runners
|
||||||
|
|
||||||
runStore :: MonadStore a -> Run IO a
|
runStore
|
||||||
runStore = runStoreOpts defaultSockPath def
|
:: ( MonadIO m
|
||||||
where
|
, MonadMask m
|
||||||
defaultSockPath :: String
|
)
|
||||||
defaultSockPath = "/nix/var/nix/daemon-socket/socket"
|
=> RemoteStoreT m a
|
||||||
|
-> Run m a
|
||||||
|
runStore = runStoreConnection def
|
||||||
|
|
||||||
runStoreOpts
|
runStoreConnection
|
||||||
:: FilePath
|
:: ( MonadIO m
|
||||||
-> StoreDir
|
, MonadMask m
|
||||||
-> MonadStore a
|
)
|
||||||
-> Run IO a
|
=> StoreConnection
|
||||||
runStoreOpts socketPath =
|
-> RemoteStoreT m a
|
||||||
runStoreOpts'
|
-> Run m a
|
||||||
Network.Socket.AF_UNIX
|
runStoreConnection sc k =
|
||||||
(SockAddrUnix socketPath)
|
connectionToSocket sc
|
||||||
|
>>= \case
|
||||||
|
Left e -> pure (Left e, mempty)
|
||||||
|
Right (fam, sock) -> runStoreSocket fam sock k
|
||||||
|
|
||||||
runStoreOptsTCP
|
runStoreSocket
|
||||||
:: String
|
:: ( MonadIO m
|
||||||
-> Int
|
, MonadMask m
|
||||||
-> StoreDir
|
)
|
||||||
-> MonadStore a
|
=> Family
|
||||||
-> 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
|
|
||||||
-> SockAddr
|
-> SockAddr
|
||||||
-> StoreDir
|
-> RemoteStoreT m a
|
||||||
-> MonadStore a
|
-> Run m a
|
||||||
-> Run IO a
|
runStoreSocket sockFamily sockAddr code =
|
||||||
runStoreOpts' sockFamily sockAddr storeRootDir code =
|
Control.Monad.Catch.bracket
|
||||||
Control.Exception.bracket
|
(liftIO open)
|
||||||
open
|
(liftIO . Network.Socket.close . hasStoreSocket)
|
||||||
(Network.Socket.close . hasStoreSocket)
|
(\s -> runRemoteStoreT s $ greetServer >> code)
|
||||||
(flip runStoreSocket code)
|
|
||||||
where
|
where
|
||||||
open = do
|
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
|
Network.Socket.connect soc sockAddr
|
||||||
pure PreStoreConfig
|
pure soc
|
||||||
{ preStoreConfig_socket = soc
|
|
||||||
, preStoreConfig_dir = storeRootDir
|
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
|
deriving via GenericArbitrary SubstituteMode
|
||||||
instance Arbitrary SubstituteMode
|
instance Arbitrary SubstituteMode
|
||||||
|
|
||||||
deriving via GenericArbitrary TestStoreConfig
|
deriving via GenericArbitrary ProtoStoreConfig
|
||||||
instance Arbitrary TestStoreConfig
|
instance Arbitrary ProtoStoreConfig
|
||||||
|
|
||||||
deriving via GenericArbitrary ProtoVersion
|
deriving via GenericArbitrary ProtoVersion
|
||||||
instance Arbitrary ProtoVersion
|
instance Arbitrary ProtoVersion
|
||||||
|
@ -32,10 +32,8 @@ import Data.HashSet (HashSet)
|
|||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
import Data.Set (Set)
|
import Data.Set (Set)
|
||||||
import Data.Some (Some)
|
import Data.Some (Some)
|
||||||
import Data.Text (Text)
|
|
||||||
|
|
||||||
import System.Nix.Build (BuildMode, BuildResult)
|
import System.Nix.Build (BuildMode, BuildResult)
|
||||||
import System.Nix.Derivation (Derivation)
|
|
||||||
import System.Nix.DerivedPath (DerivedPath)
|
import System.Nix.DerivedPath (DerivedPath)
|
||||||
import System.Nix.Hash (HashAlgo(..))
|
import System.Nix.Hash (HashAlgo(..))
|
||||||
import System.Nix.Nar (NarSource)
|
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.Remote.Client.Core
|
||||||
import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))
|
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
|
-- | Add `NarSource` to the store
|
||||||
addToStore
|
addToStore
|
||||||
:: MonadRemoteStore m
|
:: MonadRemoteStore m
|
||||||
@ -114,10 +118,18 @@ addIndirectRoot = doReq . AddIndirectRoot
|
|||||||
buildDerivation
|
buildDerivation
|
||||||
:: MonadRemoteStore m
|
:: MonadRemoteStore m
|
||||||
=> StorePath
|
=> StorePath
|
||||||
-> Derivation StorePath Text
|
|
||||||
-> BuildMode
|
-> BuildMode
|
||||||
-> m BuildResult
|
-> 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.
|
-- | Build paths if they are an actual derivations.
|
||||||
--
|
--
|
||||||
|
@ -1,6 +1,6 @@
|
|||||||
module System.Nix.Store.Remote.Client.Core
|
module System.Nix.Store.Remote.Client.Core
|
||||||
( Run
|
( Run
|
||||||
, runStoreSocket
|
, greetServer
|
||||||
, doReq
|
, doReq
|
||||||
) where
|
) where
|
||||||
|
|
||||||
@ -12,13 +12,8 @@ import Data.Some (Some(Some))
|
|||||||
import System.Nix.Nar (NarSource)
|
import System.Nix.Nar (NarSource)
|
||||||
import System.Nix.Store.Remote.Logger (processOutput)
|
import System.Nix.Store.Remote.Logger (processOutput)
|
||||||
import System.Nix.Store.Remote.MonadStore
|
import System.Nix.Store.Remote.MonadStore
|
||||||
( MonadRemoteStore
|
( MonadRemoteStore(..)
|
||||||
, RemoteStoreError(..)
|
, RemoteStoreError(..)
|
||||||
, RemoteStoreT
|
|
||||||
, runRemoteStoreT
|
|
||||||
, mapStoreConfig
|
|
||||||
, takeNarSource
|
|
||||||
, getStoreSocket
|
|
||||||
)
|
)
|
||||||
import System.Nix.Store.Remote.Socket (sockPutS, sockGetS)
|
import System.Nix.Store.Remote.Socket (sockPutS, sockGetS)
|
||||||
import System.Nix.Store.Remote.Serializer
|
import System.Nix.Store.Remote.Serializer
|
||||||
@ -31,10 +26,9 @@ import System.Nix.Store.Remote.Serializer
|
|||||||
, trustedFlag
|
, trustedFlag
|
||||||
, workerMagic
|
, 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.Logger (Logger)
|
||||||
import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion)
|
import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..))
|
||||||
import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig)
|
|
||||||
import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..))
|
import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..))
|
||||||
import System.Nix.Store.Remote.Types.StoreReply (StoreReply(..))
|
import System.Nix.Store.Remote.Types.StoreReply (StoreReply(..))
|
||||||
import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))
|
import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))
|
||||||
@ -84,91 +78,68 @@ doReq = \case
|
|||||||
$ getReplyS @a
|
$ getReplyS @a
|
||||||
)
|
)
|
||||||
|
|
||||||
runStoreSocket
|
greetServer
|
||||||
:: ( Monad m
|
:: MonadRemoteStore m
|
||||||
, MonadIO m
|
=> m ClientHandshakeOutput
|
||||||
)
|
greetServer = do
|
||||||
=> PreStoreConfig
|
sockPutS
|
||||||
-> RemoteStoreT StoreConfig m a
|
(mapErrorS
|
||||||
-> Run m a
|
RemoteStoreError_SerializerHandshake
|
||||||
runStoreSocket preStoreConfig code =
|
workerMagic
|
||||||
runRemoteStoreT preStoreConfig $ do
|
)
|
||||||
ClientHandshakeOutput{..}
|
WorkerMagic_One
|
||||||
<- greet
|
|
||||||
ClientHandshakeInput
|
|
||||||
{ clientHandshakeInputOurVersion = ourProtoVersion
|
|
||||||
}
|
|
||||||
|
|
||||||
mapStoreConfig
|
magic <-
|
||||||
(preStoreConfigToStoreConfig
|
sockGetS
|
||||||
clientHandshakeOutputLeastCommonVerison)
|
$ mapErrorS
|
||||||
code
|
RemoteStoreError_SerializerHandshake
|
||||||
|
workerMagic
|
||||||
|
|
||||||
where
|
unless
|
||||||
greet
|
(magic == WorkerMagic_Two)
|
||||||
:: MonadIO m
|
$ throwError RemoteStoreError_WorkerMagic2Mismatch
|
||||||
=> ClientHandshakeInput
|
|
||||||
-> RemoteStoreT PreStoreConfig m ClientHandshakeOutput
|
|
||||||
greet ClientHandshakeInput{..} = do
|
|
||||||
|
|
||||||
sockPutS
|
daemonVersion <- sockGetS protoVersion
|
||||||
(mapErrorS
|
|
||||||
RemoteStoreError_SerializerHandshake
|
|
||||||
workerMagic
|
|
||||||
)
|
|
||||||
WorkerMagic_One
|
|
||||||
|
|
||||||
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
|
sockGetS
|
||||||
$ mapErrorS
|
$ mapErrorS
|
||||||
RemoteStoreError_SerializerHandshake
|
RemoteStoreError_SerializerGet
|
||||||
workerMagic
|
text
|
||||||
|
pure $ Just txtVer
|
||||||
|
else pure Nothing
|
||||||
|
|
||||||
unless
|
remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35
|
||||||
(magic == WorkerMagic_Two)
|
then do
|
||||||
$ throwError RemoteStoreError_WorkerMagic2Mismatch
|
sockGetS
|
||||||
|
$ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag
|
||||||
|
else pure Nothing
|
||||||
|
|
||||||
daemonVersion <- sockGetS protoVersion
|
setProtoVersion leastCommonVersion
|
||||||
|
processOutput
|
||||||
|
|
||||||
when (daemonVersion < ProtoVersion 1 10)
|
pure ClientHandshakeOutput
|
||||||
$ throwError RemoteStoreError_ClientVersionTooOld
|
{ clientHandshakeOutputNixVersion = daemonNixVersion
|
||||||
|
, clientHandshakeOutputTrust = remoteTrustsUs
|
||||||
sockPutS protoVersion clientHandshakeInputOurVersion
|
, clientHandshakeOutputLeastCommonVersion = leastCommonVersion
|
||||||
|
, clientHandshakeOutputServerVersion = daemonVersion
|
||||||
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
|
|
||||||
}
|
|
||||||
|
@ -8,22 +8,21 @@ module System.Nix.Store.Remote.MonadStore
|
|||||||
, WorkerException(..)
|
, WorkerException(..)
|
||||||
, RemoteStoreT
|
, RemoteStoreT
|
||||||
, runRemoteStoreT
|
, runRemoteStoreT
|
||||||
, mapStoreConfig
|
, MonadRemoteStore(..)
|
||||||
, MonadRemoteStoreR(..)
|
|
||||||
, MonadRemoteStore
|
|
||||||
, getProtoVersion
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Exception (SomeException)
|
import Control.Exception (SomeException)
|
||||||
|
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
|
||||||
import Control.Monad.Except (MonadError)
|
import Control.Monad.Except (MonadError)
|
||||||
import Control.Monad.IO.Class (MonadIO)
|
import Control.Monad.IO.Class (MonadIO)
|
||||||
import Control.Monad.Reader (MonadReader, ask, asks)
|
import Control.Monad.Reader (MonadReader, ask)
|
||||||
import Control.Monad.State.Strict (get, modify)
|
import Control.Monad.State.Strict (get, gets, modify)
|
||||||
import Control.Monad.Trans (MonadTrans, lift)
|
import Control.Monad.Trans (MonadTrans, lift)
|
||||||
import Control.Monad.Trans.State.Strict (StateT, runStateT, mapStateT)
|
import Control.Monad.Trans.State.Strict (StateT, runStateT)
|
||||||
import Control.Monad.Trans.Except (ExceptT, runExceptT, mapExceptT)
|
import Control.Monad.Trans.Except (ExceptT, runExceptT)
|
||||||
import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT)
|
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
|
import Data.Default.Class (Default(def))
|
||||||
import Data.DList (DList)
|
import Data.DList (DList)
|
||||||
import Data.Word (Word64)
|
import Data.Word (Word64)
|
||||||
import Network.Socket (Socket)
|
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.Serializer (HandshakeSError, LoggerSError, RequestSError, ReplySError, SError)
|
||||||
import System.Nix.Store.Remote.Types.Logger (Logger, BasicError, ErrorInfo)
|
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.ProtoVersion (HasProtoVersion(..), ProtoVersion)
|
||||||
import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..), StoreConfig)
|
import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig(..))
|
||||||
|
|
||||||
import qualified Data.DList
|
import qualified Data.DList
|
||||||
|
|
||||||
data RemoteStoreState = RemoteStoreState {
|
data RemoteStoreState = RemoteStoreState {
|
||||||
remoteStoreState_logs :: DList Logger
|
remoteStoreStateConfig :: ProtoStoreConfig
|
||||||
, remoteStoreState_gotError :: Bool
|
, remoteStoreStateLogs :: DList Logger
|
||||||
, remoteStoreState_mDataSource :: Maybe (Word64 -> IO (Maybe ByteString))
|
, remoteStoreStateMDataSource :: Maybe (Word64 -> IO (Maybe ByteString))
|
||||||
-- ^ Source for @Logger_Read@, this will be called repeatedly
|
-- ^ Source for @Logger_Read@, this will be called repeatedly
|
||||||
-- as the daemon requests chunks of size @Word64@.
|
-- as the daemon requests chunks of size @Word64@.
|
||||||
-- If the function returns Nothing and daemon tries to read more
|
-- If the function returns Nothing and daemon tries to read more
|
||||||
-- data an error is thrown.
|
-- data an error is thrown.
|
||||||
-- Used by @AddToStoreNar@ and @ImportPaths@ operations.
|
-- Used by @AddToStoreNar@ and @ImportPaths@ operations.
|
||||||
, remoteStoreState_mDataSink :: Maybe (ByteString -> IO ())
|
, remoteStoreStateMDataSink :: Maybe (ByteString -> IO ())
|
||||||
-- ^ Sink for @Logger_Write@, called repeatedly by the daemon
|
-- ^ Sink for @Logger_Write@, called repeatedly by the daemon
|
||||||
-- to dump us some data. Used by @ExportPath@ operation.
|
-- 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
|
data RemoteStoreError
|
||||||
= RemoteStoreError_Fixme String
|
= RemoteStoreError_Fixme String
|
||||||
| RemoteStoreError_BuildFailed
|
| RemoteStoreError_BuildFailed
|
||||||
| RemoteStoreError_ClientVersionTooOld
|
| RemoteStoreError_ClientVersionTooOld
|
||||||
|
| RemoteStoreError_DerivationParse String
|
||||||
| RemoteStoreError_Disconnected
|
| RemoteStoreError_Disconnected
|
||||||
| RemoteStoreError_GetAddrInfoFailed
|
| 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
|
| 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_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_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_LoggerParserFail String ByteString -- when incremental parser returns ((Fail msg leftover) :: Result)
|
||||||
| RemoteStoreError_NoDataSourceProvided -- remoteStoreState_mDataSource is required but it is Nothing
|
| RemoteStoreError_NoDataSourceProvided -- remoteStoreStateMDataSource is required but it is Nothing
|
||||||
| RemoteStoreError_DataSourceExhausted -- remoteStoreState_mDataSource returned Nothing but more data was requested
|
| RemoteStoreError_DataSourceExhausted -- remoteStoreStateMDataSource returned Nothing but more data was requested
|
||||||
| RemoteStoreError_NoDataSinkProvided -- remoteStoreState_mDataSink is required but it is Nothing
|
| RemoteStoreError_NoDataSinkProvided -- remoteStoreStateMDataSink is required but it is Nothing
|
||||||
| RemoteStoreError_NoNarSourceProvided
|
| RemoteStoreError_NoNarSourceProvided
|
||||||
| RemoteStoreError_OperationFailed
|
| RemoteStoreError_OperationFailed
|
||||||
| RemoteStoreError_ProtocolMismatch
|
| RemoteStoreError_ProtocolMismatch
|
||||||
@ -100,91 +106,116 @@ data WorkerError
|
|||||||
| WorkerError_UnsupportedOperation
|
| WorkerError_UnsupportedOperation
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
newtype RemoteStoreT r m a = RemoteStoreT
|
newtype RemoteStoreT m a = RemoteStoreT
|
||||||
{ _unRemoteStoreT
|
{ _unRemoteStoreT
|
||||||
:: ExceptT RemoteStoreError
|
:: ExceptT RemoteStoreError
|
||||||
(StateT RemoteStoreState
|
(StateT RemoteStoreState
|
||||||
(ReaderT r m)) a
|
(ReaderT Socket m)) a
|
||||||
}
|
}
|
||||||
deriving
|
deriving
|
||||||
( Functor
|
( Functor
|
||||||
, Applicative
|
, Applicative
|
||||||
, Monad
|
, Monad
|
||||||
, MonadReader r
|
, MonadReader Socket
|
||||||
--, MonadState StoreState -- Avoid making the internal state explicit
|
--, MonadState StoreState -- Avoid making the internal state explicit
|
||||||
, MonadError RemoteStoreError
|
, MonadError RemoteStoreError
|
||||||
|
, MonadCatch
|
||||||
|
, MonadMask
|
||||||
|
, MonadThrow
|
||||||
, MonadIO
|
, MonadIO
|
||||||
)
|
)
|
||||||
|
|
||||||
instance MonadTrans (RemoteStoreT r) where
|
instance MonadTrans RemoteStoreT where
|
||||||
lift = RemoteStoreT . lift . lift . lift
|
lift = RemoteStoreT . lift . lift . lift
|
||||||
|
|
||||||
-- | Runner for @RemoteStoreT@
|
-- | Runner for @RemoteStoreT@
|
||||||
runRemoteStoreT
|
runRemoteStoreT
|
||||||
:: ( HasStoreDir r
|
:: Monad m
|
||||||
, HasStoreSocket r
|
=> Socket
|
||||||
, Monad m
|
-> RemoteStoreT m a
|
||||||
)
|
|
||||||
=> r
|
|
||||||
-> RemoteStoreT r m a
|
|
||||||
-> m (Either RemoteStoreError a, DList Logger)
|
-> m (Either RemoteStoreError a, DList Logger)
|
||||||
runRemoteStoreT r =
|
runRemoteStoreT sock =
|
||||||
fmap (\(res, RemoteStoreState{..}) -> (res, remoteStoreState_logs))
|
fmap (\(res, RemoteStoreState{..}) -> (res, remoteStoreStateLogs))
|
||||||
. (`runReaderT` r)
|
. (`runReaderT` sock)
|
||||||
. (`runStateT` emptyState)
|
. (`runStateT` emptyState)
|
||||||
. runExceptT
|
. runExceptT
|
||||||
. _unRemoteStoreT
|
. _unRemoteStoreT
|
||||||
where
|
where
|
||||||
emptyState = RemoteStoreState
|
emptyState = RemoteStoreState
|
||||||
{ remoteStoreState_logs = mempty
|
{ remoteStoreStateConfig = def
|
||||||
, remoteStoreState_gotError = False
|
, remoteStoreStateLogs = mempty
|
||||||
, remoteStoreState_mDataSource = Nothing
|
, remoteStoreStateMDataSource = Nothing
|
||||||
, remoteStoreState_mDataSink = Nothing
|
, remoteStoreStateMDataSink = Nothing
|
||||||
, remoteStoreState_mNarSource = 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
|
class ( MonadIO m
|
||||||
, MonadError RemoteStoreError m
|
, MonadError RemoteStoreError m
|
||||||
, HasStoreSocket r
|
|
||||||
, HasStoreDir r
|
|
||||||
, MonadReader r m
|
|
||||||
)
|
)
|
||||||
=> MonadRemoteStoreR r m where
|
=> MonadRemoteStore m where
|
||||||
|
|
||||||
appendLog :: Logger -> m ()
|
appendLog :: Logger -> m ()
|
||||||
default appendLog
|
default appendLog
|
||||||
:: ( MonadTrans t
|
:: ( MonadTrans t
|
||||||
, MonadRemoteStoreR r m'
|
, MonadRemoteStore m'
|
||||||
, m ~ t m'
|
, m ~ t m'
|
||||||
)
|
)
|
||||||
=> Logger
|
=> Logger
|
||||||
-> m ()
|
-> m ()
|
||||||
appendLog = lift . appendLog
|
appendLog = lift . appendLog
|
||||||
|
|
||||||
|
getConfig :: m ProtoStoreConfig
|
||||||
|
default getConfig
|
||||||
|
:: ( MonadTrans t
|
||||||
|
, MonadRemoteStore m'
|
||||||
|
, m ~ t m'
|
||||||
|
)
|
||||||
|
=> m ProtoStoreConfig
|
||||||
|
getConfig = lift getConfig
|
||||||
|
|
||||||
getStoreDir :: m StoreDir
|
getStoreDir :: m StoreDir
|
||||||
default getStoreDir
|
default getStoreDir
|
||||||
:: ( MonadTrans t
|
:: ( MonadTrans t
|
||||||
, MonadRemoteStoreR r m'
|
, MonadRemoteStore m'
|
||||||
, m ~ t m'
|
, m ~ t m'
|
||||||
)
|
)
|
||||||
=> m StoreDir
|
=> m StoreDir
|
||||||
getStoreDir = lift getStoreDir
|
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
|
getStoreSocket :: m Socket
|
||||||
default getStoreSocket
|
default getStoreSocket
|
||||||
:: ( MonadTrans t
|
:: ( MonadTrans t
|
||||||
, MonadRemoteStoreR r m'
|
, MonadRemoteStore m'
|
||||||
, m ~ t m'
|
, m ~ t m'
|
||||||
)
|
)
|
||||||
=> m Socket
|
=> m Socket
|
||||||
@ -193,7 +224,7 @@ class ( MonadIO m
|
|||||||
setNarSource :: NarSource IO -> m ()
|
setNarSource :: NarSource IO -> m ()
|
||||||
default setNarSource
|
default setNarSource
|
||||||
:: ( MonadTrans t
|
:: ( MonadTrans t
|
||||||
, MonadRemoteStoreR r m'
|
, MonadRemoteStore m'
|
||||||
, m ~ t m'
|
, m ~ t m'
|
||||||
)
|
)
|
||||||
=> NarSource IO
|
=> NarSource IO
|
||||||
@ -203,7 +234,7 @@ class ( MonadIO m
|
|||||||
takeNarSource :: m (Maybe (NarSource IO))
|
takeNarSource :: m (Maybe (NarSource IO))
|
||||||
default takeNarSource
|
default takeNarSource
|
||||||
:: ( MonadTrans t
|
:: ( MonadTrans t
|
||||||
, MonadRemoteStoreR r m'
|
, MonadRemoteStore m'
|
||||||
, m ~ t m'
|
, m ~ t m'
|
||||||
)
|
)
|
||||||
=> m (Maybe (NarSource IO))
|
=> m (Maybe (NarSource IO))
|
||||||
@ -212,7 +243,7 @@ class ( MonadIO m
|
|||||||
setDataSource :: (Word64 -> IO (Maybe ByteString)) -> m ()
|
setDataSource :: (Word64 -> IO (Maybe ByteString)) -> m ()
|
||||||
default setDataSource
|
default setDataSource
|
||||||
:: ( MonadTrans t
|
:: ( MonadTrans t
|
||||||
, MonadRemoteStoreR r m'
|
, MonadRemoteStore m'
|
||||||
, m ~ t m'
|
, m ~ t m'
|
||||||
)
|
)
|
||||||
=> (Word64 -> IO (Maybe ByteString))
|
=> (Word64 -> IO (Maybe ByteString))
|
||||||
@ -222,7 +253,7 @@ class ( MonadIO m
|
|||||||
getDataSource :: m (Maybe (Word64 -> IO (Maybe ByteString)))
|
getDataSource :: m (Maybe (Word64 -> IO (Maybe ByteString)))
|
||||||
default getDataSource
|
default getDataSource
|
||||||
:: ( MonadTrans t
|
:: ( MonadTrans t
|
||||||
, MonadRemoteStoreR r m'
|
, MonadRemoteStore m'
|
||||||
, m ~ t m'
|
, m ~ t m'
|
||||||
)
|
)
|
||||||
=> m (Maybe (Word64 -> IO (Maybe ByteString)))
|
=> m (Maybe (Word64 -> IO (Maybe ByteString)))
|
||||||
@ -231,7 +262,7 @@ class ( MonadIO m
|
|||||||
clearDataSource :: m ()
|
clearDataSource :: m ()
|
||||||
default clearDataSource
|
default clearDataSource
|
||||||
:: ( MonadTrans t
|
:: ( MonadTrans t
|
||||||
, MonadRemoteStoreR r m'
|
, MonadRemoteStore m'
|
||||||
, m ~ t m'
|
, m ~ t m'
|
||||||
)
|
)
|
||||||
=> m ()
|
=> m ()
|
||||||
@ -240,7 +271,7 @@ class ( MonadIO m
|
|||||||
setDataSink :: (ByteString -> IO ()) -> m ()
|
setDataSink :: (ByteString -> IO ()) -> m ()
|
||||||
default setDataSink
|
default setDataSink
|
||||||
:: ( MonadTrans t
|
:: ( MonadTrans t
|
||||||
, MonadRemoteStoreR r m'
|
, MonadRemoteStore m'
|
||||||
, m ~ t m'
|
, m ~ t m'
|
||||||
)
|
)
|
||||||
=> (ByteString -> IO ())
|
=> (ByteString -> IO ())
|
||||||
@ -250,7 +281,7 @@ class ( MonadIO m
|
|||||||
getDataSink :: m (Maybe (ByteString -> IO ()))
|
getDataSink :: m (Maybe (ByteString -> IO ()))
|
||||||
default getDataSink
|
default getDataSink
|
||||||
:: ( MonadTrans t
|
:: ( MonadTrans t
|
||||||
, MonadRemoteStoreR r m'
|
, MonadRemoteStore m'
|
||||||
, m ~ t m'
|
, m ~ t m'
|
||||||
)
|
)
|
||||||
=> m (Maybe (ByteString -> IO ()))
|
=> m (Maybe (ByteString -> IO ()))
|
||||||
@ -259,50 +290,49 @@ class ( MonadIO m
|
|||||||
clearDataSink :: m ()
|
clearDataSink :: m ()
|
||||||
default clearDataSink
|
default clearDataSink
|
||||||
:: ( MonadTrans t
|
:: ( MonadTrans t
|
||||||
, MonadRemoteStoreR r m'
|
, MonadRemoteStore m'
|
||||||
, m ~ t m'
|
, m ~ t m'
|
||||||
)
|
)
|
||||||
=> m ()
|
=> m ()
|
||||||
clearDataSink = lift clearDataSink
|
clearDataSink = lift clearDataSink
|
||||||
|
|
||||||
instance MonadRemoteStoreR r m => MonadRemoteStoreR r (StateT s m)
|
instance MonadRemoteStore m => MonadRemoteStore (StateT s m)
|
||||||
instance MonadRemoteStoreR r m => MonadRemoteStoreR r (ReaderT r m)
|
instance MonadRemoteStore m => MonadRemoteStore (ReaderT r m)
|
||||||
instance MonadRemoteStoreR r m => MonadRemoteStoreR r (ExceptT RemoteStoreError m)
|
instance MonadRemoteStore m => MonadRemoteStore (ExceptT RemoteStoreError m)
|
||||||
|
|
||||||
type MonadRemoteStore m = MonadRemoteStoreR StoreConfig m
|
instance MonadIO m => MonadRemoteStore (RemoteStoreT m) where
|
||||||
|
|
||||||
instance ( MonadIO m
|
getConfig = RemoteStoreT $ gets remoteStoreStateConfig
|
||||||
, HasStoreDir r
|
getProtoVersion = RemoteStoreT $ gets hasProtoVersion
|
||||||
, HasStoreSocket r
|
setProtoVersion pv =
|
||||||
)
|
RemoteStoreT $ modify $ \s ->
|
||||||
=> MonadRemoteStoreR r (RemoteStoreT r m) where
|
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 = RemoteStoreT ask
|
||||||
getStoreSocket = hasStoreSocket <$> RemoteStoreT ask
|
|
||||||
|
|
||||||
appendLog x =
|
appendLog x =
|
||||||
RemoteStoreT
|
RemoteStoreT
|
||||||
$ modify
|
$ 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 }
|
setDataSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSource = pure x }
|
||||||
getDataSource = remoteStoreState_mDataSource <$> RemoteStoreT get
|
getDataSource = RemoteStoreT (gets remoteStoreStateMDataSource)
|
||||||
clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = Nothing }
|
clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSource = Nothing }
|
||||||
|
|
||||||
setDataSink x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSink = pure x }
|
setDataSink x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSink = pure x }
|
||||||
getDataSink = remoteStoreState_mDataSink <$> RemoteStoreT get
|
getDataSink = RemoteStoreT (gets remoteStoreStateMDataSink)
|
||||||
clearDataSink = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSink = Nothing }
|
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
|
takeNarSource = RemoteStoreT $ do
|
||||||
x <- remoteStoreState_mNarSource <$> get
|
x <- remoteStoreStateMNarSource <$> get
|
||||||
modify $ \s -> s { remoteStoreState_mNarSource = Nothing }
|
modify $ \s -> s { remoteStoreStateMNarSource = Nothing }
|
||||||
pure x
|
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.Hash (HashAlgo(..))
|
||||||
import System.Nix.JSON ()
|
import System.Nix.JSON ()
|
||||||
import System.Nix.OutputName (OutputName)
|
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.Signature (Signature, NarSignature)
|
||||||
import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))
|
import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))
|
||||||
import System.Nix.StorePath (HasStoreDir(..), InvalidNameError, InvalidPathError, StorePath, StorePathHashPart, StorePathName)
|
import System.Nix.StorePath (HasStoreDir(..), InvalidNameError, InvalidPathError, StorePath, StorePathHashPart, StorePathName)
|
||||||
@ -1398,7 +1398,7 @@ derivationOutputTyped = mapErrorS ReplySError_DerivationOutput $
|
|||||||
realisation :: NixSerializer r ReplySError Realisation
|
realisation :: NixSerializer r ReplySError Realisation
|
||||||
realisation = mapErrorS ReplySError_Realisation json
|
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
|
realisationWithId = mapErrorS ReplySError_RealisationWithId json
|
||||||
|
|
||||||
-- *** BuildResult
|
-- *** BuildResult
|
||||||
@ -1434,7 +1434,7 @@ buildResult = Serializer
|
|||||||
then
|
then
|
||||||
pure
|
pure
|
||||||
. Data.Map.Strict.fromList
|
. Data.Map.Strict.fromList
|
||||||
. map (\(_, (a, b)) -> (a, b))
|
. map (\(_, RealisationWithId (a, b)) -> (a, b))
|
||||||
. Data.Map.Strict.toList
|
. Data.Map.Strict.toList
|
||||||
<$> getS (mapS derivationOutputTyped realisationWithId)
|
<$> getS (mapS derivationOutputTyped realisationWithId)
|
||||||
else pure Nothing
|
else pure Nothing
|
||||||
@ -1453,7 +1453,7 @@ buildResult = Serializer
|
|||||||
Control.Monad.when (protoVersion_minor pv >= 28)
|
Control.Monad.when (protoVersion_minor pv >= 28)
|
||||||
$ putS (mapS derivationOutputTyped realisationWithId)
|
$ putS (mapS derivationOutputTyped realisationWithId)
|
||||||
$ Data.Map.Strict.fromList
|
$ Data.Map.Strict.fromList
|
||||||
$ map (\(a, b) -> (a, (a, b)))
|
$ map (\(a, b) -> (a, RealisationWithId (a, b)))
|
||||||
$ Data.Map.Strict.toList
|
$ Data.Map.Strict.toList
|
||||||
$ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs
|
$ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs
|
||||||
}
|
}
|
||||||
|
@ -1,69 +1,81 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE Rank2Types #-}
|
{-# 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.Concurrent.Classy.Async
|
||||||
import Control.Monad (join, void, when)
|
import Control.Monad (join, void, when)
|
||||||
import Control.Monad.Conc.Class (MonadConc)
|
import Control.Monad.Conc.Class (MonadConc)
|
||||||
import Control.Monad.Except (MonadError, throwError)
|
import Control.Monad.Except (MonadError, throwError)
|
||||||
import Control.Monad.Reader (MonadReader, asks)
|
|
||||||
import Control.Monad.Trans (lift)
|
import Control.Monad.Trans (lift)
|
||||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||||
|
import Data.Default.Class (Default(def))
|
||||||
import Data.Foldable (traverse_)
|
import Data.Foldable (traverse_)
|
||||||
import Data.IORef (IORef, atomicModifyIORef, newIORef)
|
import Data.IORef (IORef, atomicModifyIORef, newIORef)
|
||||||
import Data.Some (Some(Some))
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Void (Void, absurd)
|
import Data.Void (Void, absurd)
|
||||||
import Data.Word (Word32)
|
import Data.Word (Word32)
|
||||||
import qualified Data.Text
|
|
||||||
import qualified Data.Text.IO
|
|
||||||
import Network.Socket (Socket, accept, close, listen, maxListenQueue)
|
import Network.Socket (Socket, accept, close, listen, maxListenQueue)
|
||||||
import System.Nix.StorePath (StoreDir)
|
import System.Nix.Nar (NarSource)
|
||||||
import System.Nix.Store.Remote.Serializer as RB
|
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.Socket
|
||||||
import System.Nix.Store.Remote.Types.StoreRequest as R
|
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.StoreReply
|
||||||
import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..))
|
import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..))
|
||||||
import System.Nix.Store.Remote.Types.Logger (BasicError(..), ErrorInfo, Logger(..))
|
import System.Nix.Store.Remote.Types.Logger (BasicError(..), ErrorInfo, Logger(..))
|
||||||
|
import System.Nix.Store.Remote.MonadStore (MonadRemoteStore(..), WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT)
|
||||||
import System.Nix.Store.Remote.MonadStore (WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT, mapStoreConfig)
|
|
||||||
import System.Nix.Store.Remote.Types.Handshake (ServerHandshakeInput(..), ServerHandshakeOutput(..))
|
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 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.
|
-- | Run an emulated nix daemon on given socket address.
|
||||||
-- The deamon will close when the continuation returns.
|
-- The deamon will close when the continuation returns.
|
||||||
runDaemonSocket
|
runProxyDaemon
|
||||||
:: forall m a
|
:: forall m a
|
||||||
. ( MonadIO m
|
. ( MonadIO m
|
||||||
, MonadConc m
|
, MonadConc m
|
||||||
, MonadError RemoteStoreError m
|
|
||||||
, MonadReader StoreConfig m
|
|
||||||
)
|
)
|
||||||
=> StoreDir
|
=> WorkerHelper m
|
||||||
-> WorkerHelper m
|
-> RemoteStoreT m ()
|
||||||
-> Socket
|
-> Socket
|
||||||
-> m a
|
-> m a
|
||||||
-> m a
|
-> m a
|
||||||
runDaemonSocket sd workerHelper lsock k = do
|
runProxyDaemon workerHelper postGreet lsock k = do
|
||||||
liftIO $ listen lsock maxListenQueue
|
liftIO $ listen lsock maxListenQueue
|
||||||
|
|
||||||
liftIO $ Data.Text.IO.putStrLn "listening"
|
dbg "listening"
|
||||||
|
|
||||||
let listener :: m Void
|
let listener :: m Void
|
||||||
listener = do
|
listener = do
|
||||||
(sock, _) <- liftIO $ accept lsock
|
(sock, _) <- liftIO $ accept lsock
|
||||||
liftIO $ Data.Text.IO.putStrLn "accepting"
|
dbg "accepting"
|
||||||
|
|
||||||
let preStoreConfig = PreStoreConfig
|
|
||||||
{ preStoreConfig_socket = sock
|
|
||||||
, preStoreConfig_dir = sd
|
|
||||||
}
|
|
||||||
|
|
||||||
-- TODO: this, but without the space leak
|
-- 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
|
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.
|
-- this function should take care to not throw errors from client connections.
|
||||||
processConnection
|
processConnection
|
||||||
:: ( MonadIO m
|
:: forall m
|
||||||
, MonadError RemoteStoreError m
|
. MonadIO m
|
||||||
, MonadReader StoreConfig m
|
|
||||||
)
|
|
||||||
=> WorkerHelper m
|
=> WorkerHelper m
|
||||||
-> PreStoreConfig
|
-> RemoteStoreT m ()
|
||||||
|
-> Socket
|
||||||
-> m ()
|
-> m ()
|
||||||
processConnection workerHelper preStoreConfig = do
|
processConnection workerHelper postGreet sock = do
|
||||||
~() <- void $ runRemoteStoreT preStoreConfig $ do
|
~() <- void $ runRemoteStoreT sock $ do
|
||||||
|
|
||||||
ServerHandshakeOutput{..}
|
ServerHandshakeOutput{..}
|
||||||
<- greet
|
<- greet
|
||||||
ServerHandshakeInput
|
ServerHandshakeInput
|
||||||
{ serverHandshakeInputNixVersion = "nixVersion (hnix-store-remote)"
|
{ serverHandshakeInputNixVersion = "nixVersion (hnix-store-remote)"
|
||||||
, serverHandshakeInputOurVersion= ourProtoVersion
|
, serverHandshakeInputOurVersion = def
|
||||||
, serverHandshakeInputTrust = Nothing
|
, serverHandshakeInputTrust = Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
mapStoreConfig
|
setProtoVersion serverHandshakeOutputLeastCommonVersion
|
||||||
(preStoreConfigToStoreConfig
|
|
||||||
serverHandshakeOutputLeastCommonVersion)
|
|
||||||
$ do
|
|
||||||
|
|
||||||
tunnelLogger <- liftIO $ newTunnelLogger
|
tunnelLogger <- liftIO $ newTunnelLogger
|
||||||
-- Send startup error messages to the client.
|
-- Send startup error messages to the client.
|
||||||
startWork tunnelLogger
|
startWork tunnelLogger
|
||||||
|
|
||||||
-- TODO: do we need auth at all? probably?
|
-- TODO: do we need auth at all? probably?
|
||||||
-- If we can't accept clientVersion, then throw an error *here* (not above).
|
-- If we can't accept clientVersion, then throw an error *here* (not above).
|
||||||
--authHook(*store);
|
--authHook(*store);
|
||||||
stopWork tunnelLogger
|
stopWork tunnelLogger
|
||||||
|
|
||||||
-- Process client requests.
|
-- so we can set store dir
|
||||||
let loop = do
|
postGreet
|
||||||
someReq <-
|
|
||||||
sockGetS
|
|
||||||
$ mapErrorS
|
|
||||||
RemoteStoreError_SerializerRequest
|
|
||||||
storeRequest
|
|
||||||
|
|
||||||
lift $ performOp' workerHelper tunnelLogger someReq
|
let perform
|
||||||
loop
|
:: ( Show a
|
||||||
loop
|
, StoreReply a
|
||||||
|
)
|
||||||
|
=> StoreRequest a
|
||||||
|
-> RemoteStoreT m ()
|
||||||
|
perform req = do
|
||||||
|
|
||||||
liftIO $ Data.Text.IO.putStrLn "daemon connection done"
|
special <- case req of
|
||||||
liftIO $ close $ preStoreConfig_socket preStoreConfig
|
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
|
where
|
||||||
-- Exchange the greeting.
|
-- Exchange the greeting.
|
||||||
greet
|
greet
|
||||||
:: MonadIO m
|
:: MonadIO m
|
||||||
=> ServerHandshakeInput
|
=> ServerHandshakeInput
|
||||||
-> RemoteStoreT PreStoreConfig m ServerHandshakeOutput
|
-> RemoteStoreT m ServerHandshakeOutput
|
||||||
greet ServerHandshakeInput{..} = do
|
greet ServerHandshakeInput{..} = do
|
||||||
magic <-
|
magic <-
|
||||||
sockGetS
|
sockGetS
|
||||||
@ -131,7 +212,6 @@ processConnection workerHelper preStoreConfig = do
|
|||||||
RemoteStoreError_SerializerHandshake
|
RemoteStoreError_SerializerHandshake
|
||||||
workerMagic
|
workerMagic
|
||||||
|
|
||||||
liftIO $ print ("magic" :: Text, magic)
|
|
||||||
when (magic /= WorkerMagic_One)
|
when (magic /= WorkerMagic_One)
|
||||||
$ throwError
|
$ throwError
|
||||||
$ RemoteStoreError_WorkerException
|
$ RemoteStoreError_WorkerException
|
||||||
@ -148,9 +228,7 @@ processConnection workerHelper preStoreConfig = do
|
|||||||
|
|
||||||
clientVersion <- sockGetS protoVersion
|
clientVersion <- sockGetS protoVersion
|
||||||
|
|
||||||
let leastCommonVersion = min clientVersion ourProtoVersion
|
let leastCommonVersion = min clientVersion serverHandshakeInputOurVersion
|
||||||
|
|
||||||
liftIO $ print ("Versions client, min" :: Text, clientVersion, leastCommonVersion)
|
|
||||||
|
|
||||||
when (clientVersion < ProtoVersion 1 10)
|
when (clientVersion < ProtoVersion 1 10)
|
||||||
$ throwError
|
$ throwError
|
||||||
@ -189,57 +267,13 @@ processConnection workerHelper preStoreConfig = do
|
|||||||
, serverHandshakeOutputClientVersion = clientVersion
|
, serverHandshakeOutputClientVersion = clientVersion
|
||||||
}
|
}
|
||||||
|
|
||||||
simpleOp
|
{-# WARNING _unimplemented "not yet implemented" #-}
|
||||||
:: ( MonadIO m
|
_unimplemented :: RemoteStoreError
|
||||||
, HasStoreSocket r
|
_unimplemented = RemoteStoreError_WorkerException $ WorkerException_Error $ WorkerError_NotYetImplemented
|
||||||
, 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
|
|
||||||
|
|
||||||
bracketLogger
|
bracketLogger
|
||||||
:: ( MonadIO m
|
:: MonadRemoteStore m
|
||||||
, HasStoreSocket r
|
=> TunnelLogger
|
||||||
, HasProtoVersion r
|
|
||||||
, MonadReader r m
|
|
||||||
, MonadError RemoteStoreError m
|
|
||||||
)
|
|
||||||
=> TunnelLogger r
|
|
||||||
-> m a
|
-> m a
|
||||||
-> m a
|
-> m a
|
||||||
bracketLogger tunnelLogger m = do
|
bracketLogger tunnelLogger m = do
|
||||||
@ -248,81 +282,43 @@ bracketLogger tunnelLogger m = do
|
|||||||
stopWork tunnelLogger
|
stopWork tunnelLogger
|
||||||
pure a
|
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
|
data TunnelLogger = TunnelLogger
|
||||||
{ _tunnelLogger_state :: IORef (TunnelLoggerState r)
|
{ _tunnelLogger_state :: IORef TunnelLoggerState
|
||||||
}
|
}
|
||||||
|
|
||||||
data TunnelLoggerState r = TunnelLoggerState
|
data TunnelLoggerState = TunnelLoggerState
|
||||||
{ _tunnelLoggerState_canSendStderr :: Bool
|
{ _tunnelLoggerState_canSendStderr :: Bool
|
||||||
, _tunnelLoggerState_pendingMsgs :: [Logger]
|
, _tunnelLoggerState_pendingMsgs :: [Logger]
|
||||||
}
|
}
|
||||||
|
|
||||||
newTunnelLogger :: IO (TunnelLogger r)
|
newTunnelLogger :: IO TunnelLogger
|
||||||
newTunnelLogger = TunnelLogger <$> newIORef (TunnelLoggerState False [])
|
newTunnelLogger = TunnelLogger <$> newIORef (TunnelLoggerState False [])
|
||||||
|
|
||||||
enqueueMsg
|
enqueueMsg
|
||||||
:: ( MonadIO m
|
:: ( MonadRemoteStore m
|
||||||
, MonadReader r m
|
|
||||||
, MonadError LoggerSError m
|
, MonadError LoggerSError m
|
||||||
, HasProtoVersion r
|
|
||||||
, HasStoreSocket r
|
|
||||||
)
|
)
|
||||||
=> TunnelLogger r
|
=> TunnelLogger
|
||||||
-> Logger
|
-> Logger
|
||||||
-> m ()
|
-> m ()
|
||||||
enqueueMsg x l = updateLogger x $ \st@(TunnelLoggerState c p) -> case c of
|
enqueueMsg x l = updateLogger x $ \st@(TunnelLoggerState c p) -> case c of
|
||||||
True -> (st, sockPutS logger l)
|
True -> (st, sockPutS logger l)
|
||||||
False -> (TunnelLoggerState c (l:p), pure ())
|
False -> (TunnelLoggerState c (l:p), pure ())
|
||||||
|
|
||||||
log
|
_log
|
||||||
:: ( MonadIO m
|
:: ( MonadRemoteStore m
|
||||||
, MonadReader r m
|
|
||||||
, HasStoreSocket r
|
|
||||||
, MonadError LoggerSError m
|
, MonadError LoggerSError m
|
||||||
, HasProtoVersion r
|
|
||||||
)
|
)
|
||||||
=> TunnelLogger r
|
=> TunnelLogger
|
||||||
-> Text
|
-> Text
|
||||||
-> m ()
|
-> m ()
|
||||||
log l s = enqueueMsg l (Logger_Next s)
|
_log l s = enqueueMsg l (Logger_Next s)
|
||||||
|
|
||||||
startWork
|
startWork
|
||||||
:: (MonadIO m, MonadReader r m, HasStoreSocket r
|
:: MonadRemoteStore m
|
||||||
|
=> TunnelLogger
|
||||||
, MonadError RemoteStoreError m
|
|
||||||
, HasProtoVersion r
|
|
||||||
)
|
|
||||||
=> TunnelLogger r
|
|
||||||
-> m ()
|
-> m ()
|
||||||
startWork x = updateLogger x $ \(TunnelLoggerState _ p) -> (,)
|
startWork x = updateLogger x $ \(TunnelLoggerState _ p) -> (,)
|
||||||
(TunnelLoggerState True []) $
|
(TunnelLoggerState True []) $
|
||||||
@ -330,12 +326,8 @@ startWork x = updateLogger x $ \(TunnelLoggerState _ p) -> (,)
|
|||||||
where logger' = mapErrorS RemoteStoreError_SerializerLogger logger
|
where logger' = mapErrorS RemoteStoreError_SerializerLogger logger
|
||||||
|
|
||||||
stopWork
|
stopWork
|
||||||
:: (MonadIO m, MonadReader r m, HasStoreSocket r
|
:: MonadRemoteStore m
|
||||||
|
=> TunnelLogger
|
||||||
, MonadError RemoteStoreError m
|
|
||||||
, HasProtoVersion r
|
|
||||||
)
|
|
||||||
=> TunnelLogger r
|
|
||||||
-> m ()
|
-> m ()
|
||||||
stopWork x = updateLogger x $ \_ -> (,)
|
stopWork x = updateLogger x $ \_ -> (,)
|
||||||
(TunnelLoggerState False [])
|
(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
|
-- Unlike 'stopWork', this function may be called at any time to (try) to end a
|
||||||
-- session with an error.
|
-- session with an error.
|
||||||
stopWorkOnError
|
_stopWorkOnError
|
||||||
:: (MonadIO m, MonadReader r m, HasStoreSocket r, HasProtoVersion r
|
:: MonadRemoteStore m
|
||||||
|
=> TunnelLogger
|
||||||
, MonadError RemoteStoreError m
|
|
||||||
)
|
|
||||||
=> TunnelLogger r
|
|
||||||
-> ErrorInfo
|
-> ErrorInfo
|
||||||
-> m Bool
|
-> m Bool
|
||||||
stopWorkOnError x ex = updateLogger x $ \st ->
|
_stopWorkOnError x ex = updateLogger x $ \st ->
|
||||||
case _tunnelLoggerState_canSendStderr st of
|
case _tunnelLoggerState_canSendStderr st of
|
||||||
False -> (st, pure False)
|
False -> (st, pure False)
|
||||||
True -> (,) (TunnelLoggerState False []) $ do
|
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))
|
then sockPutS logger' (Logger_Error (Right ex))
|
||||||
else sockPutS logger' (Logger_Error (Left (BasicError 0 (Data.Text.pack $ show ex))))
|
else sockPutS logger' (Logger_Error (Left (BasicError 0 (Data.Text.pack $ show ex))))
|
||||||
pure True
|
pure True
|
||||||
where logger' = mapErrorS RemoteStoreError_SerializerLogger logger
|
where logger' = mapErrorS RemoteStoreError_SerializerLogger logger
|
||||||
|
|
||||||
updateLogger
|
updateLogger
|
||||||
:: (MonadIO m, MonadReader r m, HasStoreSocket r)
|
:: MonadRemoteStore m
|
||||||
=> TunnelLogger r
|
=> TunnelLogger
|
||||||
-> (TunnelLoggerState r -> (TunnelLoggerState r, m a))
|
-> (TunnelLoggerState -> (TunnelLoggerState, m a))
|
||||||
-> m a
|
-> m a
|
||||||
updateLogger x = join . liftIO . atomicModifyIORef (_tunnelLogger_state x)
|
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.Except (MonadError, throwError)
|
||||||
import Control.Monad.IO.Class (MonadIO(..))
|
import Control.Monad.IO.Class (MonadIO(..))
|
||||||
import Control.Monad.Reader (MonadReader, ask, asks)
|
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import Data.Serialize.Get (Get, Result(..))
|
import Data.Serialize.Get (Get, Result(..))
|
||||||
import Data.Serialize.Put (Put, runPut)
|
import Data.Serialize.Put (Put, runPut)
|
||||||
import Network.Socket.ByteString (recv, sendAll)
|
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.Serializer (NixSerializer, runP, runSerialT)
|
||||||
import System.Nix.Store.Remote.Types (HasStoreSocket(..))
|
import System.Nix.Store.Remote.Types (ProtoStoreConfig)
|
||||||
|
|
||||||
import qualified Control.Exception
|
import qualified Control.Exception
|
||||||
import qualified Data.ByteString
|
import qualified Data.ByteString
|
||||||
@ -47,14 +46,10 @@ genericIncremental getsome parser = do
|
|||||||
leftover
|
leftover
|
||||||
|
|
||||||
sockGet8
|
sockGet8
|
||||||
:: ( MonadIO m
|
:: MonadRemoteStore m
|
||||||
, MonadError RemoteStoreError m
|
|
||||||
, MonadReader r m
|
|
||||||
, HasStoreSocket r
|
|
||||||
)
|
|
||||||
=> m ByteString
|
=> m ByteString
|
||||||
sockGet8 = do
|
sockGet8 = do
|
||||||
soc <- asks hasStoreSocket
|
soc <- getStoreSocket
|
||||||
eresult <- liftIO $ Control.Exception.try $ recv soc 8
|
eresult <- liftIO $ Control.Exception.try $ recv soc 8
|
||||||
case eresult of
|
case eresult of
|
||||||
Left e ->
|
Left e ->
|
||||||
@ -67,46 +62,39 @@ sockGet8 = do
|
|||||||
pure result
|
pure result
|
||||||
|
|
||||||
sockPut
|
sockPut
|
||||||
:: ( MonadRemoteStoreR r m
|
:: MonadRemoteStore m
|
||||||
, HasStoreSocket r
|
|
||||||
)
|
|
||||||
=> Put
|
=> Put
|
||||||
-> m ()
|
-> m ()
|
||||||
sockPut p = do
|
sockPut p = do
|
||||||
soc <- asks hasStoreSocket
|
soc <- getStoreSocket
|
||||||
liftIO $ sendAll soc $ runPut p
|
liftIO $ sendAll soc $ runPut p
|
||||||
|
|
||||||
sockPutS
|
sockPutS
|
||||||
:: ( MonadReader r m
|
:: ( MonadRemoteStore m
|
||||||
, MonadError e m
|
, MonadError e m
|
||||||
, MonadIO m
|
|
||||||
, HasStoreSocket r
|
|
||||||
)
|
)
|
||||||
=> NixSerializer r e a
|
=> NixSerializer ProtoStoreConfig e a
|
||||||
-> a
|
-> a
|
||||||
-> m ()
|
-> m ()
|
||||||
sockPutS s a = do
|
sockPutS s a = do
|
||||||
r <- ask
|
cfg <- getConfig
|
||||||
case runP s r a of
|
sock <- getStoreSocket
|
||||||
Right x -> liftIO $ sendAll (hasStoreSocket r) x
|
case runP s cfg a of
|
||||||
|
Right x -> liftIO $ sendAll sock x
|
||||||
Left e -> throwError e
|
Left e -> throwError e
|
||||||
|
|
||||||
sockGetS
|
sockGetS
|
||||||
:: forall r e m a
|
:: ( MonadRemoteStore m
|
||||||
. ( HasStoreSocket r
|
|
||||||
, MonadError RemoteStoreError m
|
|
||||||
, MonadError e m
|
, MonadError e m
|
||||||
, MonadReader r m
|
|
||||||
, MonadIO m
|
|
||||||
, Show a
|
, Show a
|
||||||
, Show e
|
, Show e
|
||||||
)
|
)
|
||||||
=> NixSerializer r e a
|
=> NixSerializer ProtoStoreConfig e a
|
||||||
-> m a
|
-> m a
|
||||||
sockGetS s = do
|
sockGetS s = do
|
||||||
r <- ask
|
cfg <- getConfig
|
||||||
res <- genericIncremental sockGet8
|
res <- genericIncremental sockGet8
|
||||||
$ runSerialT r $ Data.Serializer.getS s
|
$ runSerialT cfg $ Data.Serializer.getS s
|
||||||
|
|
||||||
case res of
|
case res of
|
||||||
Right x -> pure x
|
Right x -> pure x
|
||||||
|
@ -19,7 +19,7 @@ data ClientHandshakeInput = ClientHandshakeInput
|
|||||||
data ClientHandshakeOutput = ClientHandshakeOutput
|
data ClientHandshakeOutput = ClientHandshakeOutput
|
||||||
{ clientHandshakeOutputNixVersion :: Maybe Text -- ^ Textual version, since 1.33
|
{ clientHandshakeOutputNixVersion :: Maybe Text -- ^ Textual version, since 1.33
|
||||||
, clientHandshakeOutputTrust :: Maybe TrustedFlag -- ^ Whether remote side trusts us
|
, 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
|
, clientHandshakeOutputServerVersion :: ProtoVersion -- ^ Protocol version supported by the server
|
||||||
} deriving (Eq, Generic, Ord, Show)
|
} deriving (Eq, Generic, Ord, Show)
|
||||||
|
|
||||||
|
@ -1,11 +1,11 @@
|
|||||||
module System.Nix.Store.Remote.Types.ProtoVersion
|
module System.Nix.Store.Remote.Types.ProtoVersion
|
||||||
( ProtoVersion(..)
|
( ProtoVersion(..)
|
||||||
, HasProtoVersion(..)
|
, HasProtoVersion(..)
|
||||||
, ourProtoVersion
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Data.Default.Class (Default(def))
|
||||||
import Data.Word (Word8, Word16)
|
import Data.Word (Word8, Word16)
|
||||||
import GHC.Generics
|
import GHC.Generics (Generic)
|
||||||
|
|
||||||
data ProtoVersion = ProtoVersion
|
data ProtoVersion = ProtoVersion
|
||||||
{ protoVersion_major :: Word16
|
{ protoVersion_major :: Word16
|
||||||
@ -13,15 +13,15 @@ data ProtoVersion = ProtoVersion
|
|||||||
}
|
}
|
||||||
deriving (Eq, Generic, Ord, Show)
|
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
|
class HasProtoVersion r where
|
||||||
hasProtoVersion :: r -> ProtoVersion
|
hasProtoVersion :: r -> ProtoVersion
|
||||||
|
|
||||||
instance HasProtoVersion ProtoVersion where
|
instance HasProtoVersion ProtoVersion where
|
||||||
hasProtoVersion = id
|
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 #-}
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
module System.Nix.Store.Remote.Types.StoreConfig
|
module System.Nix.Store.Remote.Types.StoreConfig
|
||||||
( PreStoreConfig(..)
|
( ProtoStoreConfig(..)
|
||||||
, StoreConfig(..)
|
, StoreSocketPath(..)
|
||||||
, TestStoreConfig(..)
|
, StoreTCP(..)
|
||||||
|
, StoreConnection(..)
|
||||||
, HasStoreSocket(..)
|
, HasStoreSocket(..)
|
||||||
, preStoreConfigToStoreConfig
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Data.Default.Class (Default(def))
|
||||||
|
import Data.String (IsString)
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Network.Socket (Socket)
|
import Network.Socket (Socket)
|
||||||
import System.Nix.StorePath (HasStoreDir(..), StoreDir)
|
import System.Nix.StorePath (HasStoreDir(..), StoreDir)
|
||||||
import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion)
|
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
|
class HasStoreSocket r where
|
||||||
hasStoreSocket :: r -> Socket
|
hasStoreSocket :: r -> Socket
|
||||||
|
|
||||||
instance HasStoreSocket Socket where
|
instance HasStoreSocket Socket where
|
||||||
hasStoreSocket = id
|
hasStoreSocket = id
|
||||||
|
|
||||||
instance HasStoreSocket PreStoreConfig where
|
data ProtoStoreConfig = ProtoStoreConfig
|
||||||
hasStoreSocket = preStoreConfig_socket
|
{ protoStoreConfigDir :: StoreDir
|
||||||
|
, protoStoreConfigProtoVersion :: ProtoVersion
|
||||||
|
} deriving (Eq, Generic, Ord, Show)
|
||||||
|
|
||||||
data StoreConfig = StoreConfig
|
instance Default ProtoStoreConfig where
|
||||||
{ storeConfig_dir :: StoreDir
|
def = ProtoStoreConfig def def
|
||||||
, storeConfig_protoVersion :: ProtoVersion
|
|
||||||
, storeConfig_socket :: Socket
|
|
||||||
}
|
|
||||||
|
|
||||||
instance HasStoreDir StoreDir where
|
instance HasStoreDir StoreDir where
|
||||||
hasStoreDir = id
|
hasStoreDir = id
|
||||||
|
|
||||||
instance HasStoreDir StoreConfig where
|
instance HasStoreDir ProtoStoreConfig where
|
||||||
hasStoreDir = storeConfig_dir
|
hasStoreDir = protoStoreConfigDir
|
||||||
|
|
||||||
instance HasProtoVersion StoreConfig where
|
instance HasProtoVersion ProtoStoreConfig where
|
||||||
hasProtoVersion = storeConfig_protoVersion
|
hasProtoVersion = protoStoreConfigProtoVersion
|
||||||
|
|
||||||
instance HasStoreSocket StoreConfig where
|
newtype StoreSocketPath = StoreSocketPath
|
||||||
hasStoreSocket = storeConfig_socket
|
{ unStoreSocketPath :: FilePath
|
||||||
|
}
|
||||||
|
deriving newtype (IsString)
|
||||||
|
deriving stock (Eq, Generic, Ord, Show)
|
||||||
|
|
||||||
data TestStoreConfig = TestStoreConfig
|
instance Default StoreSocketPath where
|
||||||
{ testStoreConfig_dir :: StoreDir
|
def = StoreSocketPath "/nix/var/nix/daemon-socket/socket"
|
||||||
, testStoreConfig_protoVersion :: ProtoVersion
|
|
||||||
|
data StoreTCP = StoreTCP
|
||||||
|
{ storeTCPHost :: String
|
||||||
|
, storeTCPPort :: Int
|
||||||
} deriving (Eq, Generic, Ord, Show)
|
} deriving (Eq, Generic, Ord, Show)
|
||||||
|
|
||||||
instance HasProtoVersion TestStoreConfig where
|
data StoreConnection
|
||||||
hasProtoVersion = testStoreConfig_protoVersion
|
= StoreConnection_Socket StoreSocketPath
|
||||||
|
| StoreConnection_TCP StoreTCP
|
||||||
|
deriving (Eq, Generic, Ord, Show)
|
||||||
|
|
||||||
instance HasStoreDir TestStoreConfig where
|
instance Default StoreConnection where
|
||||||
hasStoreDir = testStoreConfig_dir
|
def = StoreConnection_Socket def
|
||||||
|
|
||||||
-- | 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
|
|
||||||
}
|
|
||||||
|
@ -5,12 +5,12 @@ module System.Nix.Store.Remote.Types.StoreReply
|
|||||||
import Data.HashSet (HashSet)
|
import Data.HashSet (HashSet)
|
||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
import System.Nix.Build (BuildResult)
|
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.StorePath.Metadata (Metadata)
|
||||||
import System.Nix.Store.Remote.Serializer
|
import System.Nix.Store.Remote.Serializer
|
||||||
import System.Nix.Store.Remote.Types.GC (GCResult, GCRoot)
|
import System.Nix.Store.Remote.Types.GC (GCResult, GCRoot)
|
||||||
import System.Nix.Store.Remote.Types.Query.Missing (Missing)
|
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@
|
-- | Get @NixSerializer@ for some type @a@
|
||||||
-- This could also be generalized for every type
|
-- 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
|
-- this for replies and it would make look serializers
|
||||||
-- quite hodor, like @a <- getS get; b <- getS get@
|
-- quite hodor, like @a <- getS get; b <- getS get@
|
||||||
class StoreReply a where
|
class StoreReply a where
|
||||||
getReplyS
|
getReplyS :: NixSerializer ProtoStoreConfig ReplySError a
|
||||||
:: ( HasStoreDir r
|
|
||||||
, HasProtoVersion r
|
|
||||||
)
|
|
||||||
=> NixSerializer r ReplySError a
|
|
||||||
|
|
||||||
instance StoreReply () where
|
instance StoreReply () where
|
||||||
getReplyS = opSuccess
|
getReplyS = opSuccess
|
||||||
|
@ -5,12 +5,15 @@ module NixDaemonSpec
|
|||||||
, spec
|
, spec
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Control.Exception (catch, SomeException)
|
||||||
import Control.Monad (forM_, unless, void)
|
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 Crypto.Hash (SHA256)
|
||||||
import Data.Some (Some(Some))
|
import Data.Some (Some(Some))
|
||||||
import Data.Text (Text)
|
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.Expectations.Lifted
|
||||||
import Test.Hspec.Nix (forceRight)
|
import Test.Hspec.Nix (forceRight)
|
||||||
import System.FilePath ((</>))
|
import System.FilePath ((</>))
|
||||||
@ -21,7 +24,7 @@ import System.Nix.DerivedPath (DerivedPath(..))
|
|||||||
import System.Nix.StorePath (StoreDir(..), StorePath)
|
import System.Nix.StorePath (StoreDir(..), StorePath)
|
||||||
import System.Nix.StorePath.Metadata (Metadata(..))
|
import System.Nix.StorePath.Metadata (Metadata(..))
|
||||||
import System.Nix.Store.Remote
|
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 System.Process (CreateProcess(..), ProcessHandle)
|
||||||
import qualified Control.Concurrent
|
import qualified Control.Concurrent
|
||||||
import qualified Control.Exception
|
import qualified Control.Exception
|
||||||
@ -38,21 +41,19 @@ import qualified System.IO.Temp
|
|||||||
import qualified System.Linux.Namespaces
|
import qualified System.Linux.Namespaces
|
||||||
import qualified System.Nix.StorePath
|
import qualified System.Nix.StorePath
|
||||||
import qualified System.Nix.Nar
|
import qualified System.Nix.Nar
|
||||||
import qualified System.Nix.Store.Remote.MonadStore
|
|
||||||
import qualified System.Posix.User
|
import qualified System.Posix.User
|
||||||
import qualified System.Process
|
import qualified System.Process
|
||||||
import qualified Test.Hspec
|
import qualified Test.Hspec
|
||||||
|
|
||||||
createProcessEnv
|
createProcessEnv
|
||||||
:: FilePath
|
:: FilePath
|
||||||
-> String
|
-> CreateProcess
|
||||||
-> [String]
|
|
||||||
-> IO ProcessHandle
|
-> IO ProcessHandle
|
||||||
createProcessEnv fp proc args = do
|
createProcessEnv fp cp = do
|
||||||
mPath <- System.Environment.lookupEnv "PATH"
|
mPath <- System.Environment.lookupEnv "PATH"
|
||||||
|
|
||||||
(_, _, _, ph) <-
|
(_, _, _, ph) <-
|
||||||
System.Process.createProcess (System.Process.proc proc args)
|
System.Process.createProcess cp
|
||||||
{ cwd = Just fp
|
{ cwd = Just fp
|
||||||
, env = Just $ mockedEnv mPath fp
|
, env = Just $ mockedEnv mPath fp
|
||||||
}
|
}
|
||||||
@ -106,19 +107,19 @@ error: changing ownership of path '/run/user/1000/test-nix-store-06b0d249e561612
|
|||||||
-}
|
-}
|
||||||
|
|
||||||
startDaemon
|
startDaemon
|
||||||
:: FilePath
|
:: FilePath -- ^ Temporary directory
|
||||||
-> IO (ProcessHandle, MonadStore a -> Run IO a)
|
-> IO (ProcessHandle, StoreConnection)
|
||||||
startDaemon fp = do
|
startDaemon fp = do
|
||||||
writeConf (fp </> "etc" </> "nix.conf")
|
writeConf (fp </> "etc" </> "nix.conf")
|
||||||
procHandle <- createProcessEnv fp "nix-daemon" []
|
procHandle <-
|
||||||
|
createProcessEnv
|
||||||
|
fp
|
||||||
|
$ System.Process.proc "nix-daemon" mempty
|
||||||
|
|
||||||
waitSocket sockFp 30
|
waitSocket sockFp 30
|
||||||
pure ( procHandle
|
pure ( procHandle
|
||||||
, runStoreOpts
|
, StoreConnection_Socket
|
||||||
sockFp
|
$ StoreSocketPath sockFp
|
||||||
(StoreDir
|
|
||||||
$ Data.ByteString.Char8.pack
|
|
||||||
$ fp </> "store"
|
|
||||||
)
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
sockFp = fp </> "var/nix/daemon-socket/socket"
|
sockFp = fp </> "var/nix/daemon-socket/socket"
|
||||||
@ -146,10 +147,10 @@ enterNamespaces = do
|
|||||||
[ GroupMapping 0 gid 1 ]
|
[ GroupMapping 0 gid 1 ]
|
||||||
True
|
True
|
||||||
|
|
||||||
withNixDaemon
|
withNixDaemon'
|
||||||
:: ((MonadStore a -> Run IO a) -> IO a)
|
:: (FilePath -> StoreDir -> StoreConnection -> IO a)
|
||||||
-> IO a
|
-> IO a
|
||||||
withNixDaemon action =
|
withNixDaemon' action =
|
||||||
System.IO.Temp.withSystemTempDirectory "test-nix-store" $ \path -> do
|
System.IO.Temp.withSystemTempDirectory "test-nix-store" $ \path -> do
|
||||||
|
|
||||||
mapM_ (System.Directory.createDirectory . snd)
|
mapM_ (System.Directory.createDirectory . snd)
|
||||||
@ -157,17 +158,69 @@ withNixDaemon action =
|
|||||||
((/= "NIX_REMOTE") . fst)
|
((/= "NIX_REMOTE") . fst)
|
||||||
$ mockedEnv Nothing path)
|
$ 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
|
void $ System.Process.waitForProcess ini
|
||||||
|
|
||||||
writeFile (path </> "dummy") "Hello World"
|
writeFile (path </> "dummy") "Hello World"
|
||||||
|
|
||||||
System.Directory.setCurrentDirectory path
|
System.Directory.setCurrentDirectory path
|
||||||
|
let storeDir =
|
||||||
|
StoreDir
|
||||||
|
$ Data.ByteString.Char8.pack
|
||||||
|
$ path </> "store"
|
||||||
|
|
||||||
Control.Exception.bracket
|
Control.Exception.bracket
|
||||||
(startDaemon path)
|
(startDaemon path)
|
||||||
(System.Process.terminateProcess . fst)
|
(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
|
checks
|
||||||
:: ( Show a
|
:: ( Show a
|
||||||
@ -211,8 +264,9 @@ itLefts
|
|||||||
itLefts name action = it name action Data.Either.isLeft
|
itLefts name action = it name action Data.Either.isLeft
|
||||||
|
|
||||||
withPath
|
withPath
|
||||||
:: (StorePath -> MonadStore a)
|
:: MonadRemoteStore m
|
||||||
-> MonadStore a
|
=> (StorePath -> m a)
|
||||||
|
-> m a
|
||||||
withPath action = do
|
withPath action = do
|
||||||
path <-
|
path <-
|
||||||
addTextToStore
|
addTextToStore
|
||||||
@ -225,7 +279,7 @@ withPath action = do
|
|||||||
action path
|
action path
|
||||||
|
|
||||||
-- | dummy path, adds <tmp>/dummy with "Hello World" contents
|
-- | dummy path, adds <tmp>/dummy with "Hello World" contents
|
||||||
dummy :: MonadStore StorePath
|
dummy :: MonadRemoteStore m => m StorePath
|
||||||
dummy = do
|
dummy = do
|
||||||
addToStore
|
addToStore
|
||||||
(forceRight $ System.Nix.StorePath.mkStorePathName "dummy")
|
(forceRight $ System.Nix.StorePath.mkStorePathName "dummy")
|
||||||
@ -250,7 +304,10 @@ _withBuilder
|
|||||||
_withBuilder action = do
|
_withBuilder action = do
|
||||||
path <-
|
path <-
|
||||||
addTextToStore
|
addTextToStore
|
||||||
(StoreText (forceRight $ System.Nix.StorePath.mkStorePathName "builder") builderSh)
|
(StoreText
|
||||||
|
(forceRight $ System.Nix.StorePath.mkStorePathName "builder")
|
||||||
|
builderSh
|
||||||
|
)
|
||||||
mempty
|
mempty
|
||||||
RepairMode_DontRepair
|
RepairMode_DontRepair
|
||||||
action path
|
action path
|
||||||
@ -259,139 +316,175 @@ builderSh :: Text
|
|||||||
builderSh = "declare -xpexport > $out"
|
builderSh = "declare -xpexport > $out"
|
||||||
|
|
||||||
spec :: Spec
|
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" $
|
makeProtoSpec
|
||||||
itRights "syncs with garbage collector" syncWithGC
|
:: (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
|
context "verifyStore" $ do
|
||||||
itRights "check=False repair=False" $
|
itRights "check=False repair=False" $
|
||||||
verifyStore
|
verifyStore
|
||||||
CheckMode_DontCheck
|
CheckMode_DontCheck
|
||||||
RepairMode_DontRepair
|
RepairMode_DontRepair
|
||||||
`shouldReturn` False
|
`shouldReturn` False
|
||||||
|
|
||||||
itRights "check=True repair=False" $
|
itRights "check=True repair=False" $
|
||||||
verifyStore
|
verifyStore
|
||||||
CheckMode_DoCheck
|
CheckMode_DoCheck
|
||||||
RepairMode_DontRepair
|
RepairMode_DontRepair
|
||||||
`shouldReturn` False
|
`shouldReturn` False
|
||||||
|
|
||||||
--privileged
|
--privileged
|
||||||
itRights "check=True repair=True" $
|
itRights "check=True repair=True" $
|
||||||
verifyStore
|
verifyStore
|
||||||
CheckMode_DoCheck
|
CheckMode_DoCheck
|
||||||
RepairMode_DoRepair
|
RepairMode_DoRepair
|
||||||
`shouldReturn` False
|
`shouldReturn` False
|
||||||
|
|
||||||
context "addTextToStore" $
|
context "addTextToStore" $
|
||||||
itRights "adds text to store" $ withPath pure
|
itRights "adds text to store" $ withPath pure
|
||||||
|
|
||||||
context "isValidPath" $ do
|
context "isValidPath" $ do
|
||||||
itRights "validates path" $ withPath $ \path -> do
|
itRights "validates path" $ withPath $ \path -> do
|
||||||
liftIO $ print path
|
isValidPath path `shouldReturn` True
|
||||||
isValidPath path `shouldReturn` True
|
|
||||||
itLefts "fails on invalid path"
|
|
||||||
$ System.Nix.Store.Remote.MonadStore.mapStoreConfig
|
|
||||||
(\sc -> sc { storeConfig_dir = StoreDir "/asdf" })
|
|
||||||
$ isValidPath invalidPath
|
|
||||||
|
|
||||||
context "queryAllValidPaths" $ do
|
itLefts "fails on invalid path" $ do
|
||||||
itRights "empty query" queryAllValidPaths
|
setStoreDir (StoreDir "/asdf")
|
||||||
itRights "non-empty query" $ withPath $ \path ->
|
isValidPath invalidPath
|
||||||
queryAllValidPaths `shouldReturn` Data.HashSet.fromList [path]
|
|
||||||
|
|
||||||
context "queryPathInfo" $
|
context "queryAllValidPaths" $ do
|
||||||
itRights "queries path info" $ withPath $ \path -> do
|
itRights "empty query" queryAllValidPaths
|
||||||
meta <- queryPathInfo path
|
itRights "non-empty query" $ withPath $ \path ->
|
||||||
(metadataReferences <$> meta) `shouldBe` (Just mempty)
|
queryAllValidPaths `shouldReturn` Data.HashSet.fromList [path]
|
||||||
|
|
||||||
context "ensurePath" $
|
context "queryPathInfo" $
|
||||||
itRights "simple ensure" $ withPath ensurePath
|
itRights "queries path info" $ withPath $ \path -> do
|
||||||
|
meta <- queryPathInfo path
|
||||||
|
(metadataReferences <$> meta) `shouldBe` (Just mempty)
|
||||||
|
|
||||||
context "addTempRoot" $
|
context "ensurePath" $
|
||||||
itRights "simple addition" $ withPath addTempRoot
|
itRights "simple ensure" $ withPath ensurePath
|
||||||
|
|
||||||
context "addIndirectRoot" $
|
context "addTempRoot" $
|
||||||
itRights "simple addition" $ withPath addIndirectRoot
|
itRights "simple addition" $ withPath addTempRoot
|
||||||
|
|
||||||
let toDerivedPathSet p = Data.Set.fromList [DerivedPath_Opaque p]
|
context "addIndirectRoot" $
|
||||||
|
itRights "simple addition" $ withPath addIndirectRoot
|
||||||
|
|
||||||
context "buildPaths" $ do
|
let toDerivedPathSet p = Data.Set.fromList [DerivedPath_Opaque p]
|
||||||
itRights "build Normal" $ withPath $ \path -> do
|
|
||||||
buildPaths (toDerivedPathSet path) BuildMode_Normal
|
|
||||||
|
|
||||||
itRights "build Check" $ withPath $ \path -> do
|
context "buildPaths" $ do
|
||||||
buildPaths (toDerivedPathSet path) BuildMode_Check
|
itRights "build Normal" $ withPath $ \path -> do
|
||||||
|
buildPaths (toDerivedPathSet path) BuildMode_Normal
|
||||||
|
|
||||||
itLefts "build Repair" $ withPath $ \path -> do
|
itRights "build Check" $ withPath $ \path -> do
|
||||||
buildPaths (toDerivedPathSet path) BuildMode_Repair
|
buildPaths (toDerivedPathSet path) BuildMode_Check
|
||||||
|
|
||||||
context "roots" $ context "findRoots" $ do
|
itLefts "build Repair" $ withPath $ \path -> do
|
||||||
itRights "empty roots" (findRoots `shouldReturn` mempty)
|
buildPaths (toDerivedPathSet path) BuildMode_Repair
|
||||||
|
|
||||||
itRights "path added as a temp root" $ withPath $ \_ -> do
|
context "roots" $ context "findRoots" $ do
|
||||||
roots <- findRoots
|
itRights "empty roots" (findRoots `shouldReturn` mempty)
|
||||||
roots `shouldSatisfy` ((== 1) . Data.Map.size)
|
|
||||||
|
|
||||||
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 "indirect root" $ withPath $ \path -> do
|
||||||
itRights "queries" $ withPath $ \path -> do
|
let expectRoots =
|
||||||
queryMissing (toDerivedPathSet path)
|
if flavor == SpecFlavor_MITM
|
||||||
`shouldReturn`
|
then 1 -- nested client closes its connection so temp root gets removed
|
||||||
Missing
|
else 2
|
||||||
{ missingWillBuild = mempty
|
addIndirectRoot path
|
||||||
, missingWillSubstitute = mempty
|
roots <- findRoots
|
||||||
, missingUnknownPaths = mempty
|
roots `shouldSatisfy` ((== expectRoots) . Data.Map.size)
|
||||||
, missingDownloadSize = 0
|
|
||||||
, missingNarSize = 0
|
|
||||||
}
|
|
||||||
|
|
||||||
context "addToStore" $
|
context "optimiseStore" $ itRights "optimises" optimiseStore
|
||||||
itRights "adds file to store" $ do
|
|
||||||
fp <-
|
|
||||||
liftIO
|
|
||||||
$ System.IO.Temp.writeSystemTempFile
|
|
||||||
"addition"
|
|
||||||
"yolo"
|
|
||||||
|
|
||||||
addToStore
|
context "queryMissing" $
|
||||||
(forceRight $ System.Nix.StorePath.mkStorePathName "tmp-addition")
|
itRights "queries" $ withPath $ \path -> do
|
||||||
(System.Nix.Nar.dumpPath fp)
|
queryMissing (toDerivedPathSet path)
|
||||||
FileIngestionMethod_Flat
|
`shouldReturn`
|
||||||
(Some HashAlgo_SHA256)
|
Missing
|
||||||
RepairMode_DontRepair
|
{ missingWillBuild = mempty
|
||||||
|
, missingWillSubstitute = mempty
|
||||||
|
, missingUnknownPaths = mempty
|
||||||
|
, missingDownloadSize = 0
|
||||||
|
, missingNarSize = 0
|
||||||
|
}
|
||||||
|
|
||||||
context "with dummy" $ do
|
context "addToStore" $
|
||||||
itRights "adds dummy" dummy
|
itRights "adds file to store" $ do
|
||||||
|
fp <-
|
||||||
|
liftIO
|
||||||
|
$ System.IO.Temp.writeSystemTempFile
|
||||||
|
"addition"
|
||||||
|
"yolo"
|
||||||
|
|
||||||
itRights "valid dummy" $ do
|
addToStore
|
||||||
path <- dummy
|
(forceRight $ System.Nix.StorePath.mkStorePathName "tmp-addition")
|
||||||
isValidPath path `shouldReturn` True
|
(System.Nix.Nar.dumpPath fp)
|
||||||
|
FileIngestionMethod_Flat
|
||||||
|
(Some HashAlgo_SHA256)
|
||||||
|
RepairMode_DontRepair
|
||||||
|
|
||||||
context "collectGarbage" $ do
|
context "with dummy" $ do
|
||||||
itRights "delete a specific path from the store" $ withPath $ \path -> do
|
itRights "adds dummy" dummy
|
||||||
-- clear temp gc roots so the delete works. restarting the nix daemon should also do this...
|
|
||||||
storeDir <- getStoreDir
|
itRights "valid dummy" $ do
|
||||||
let tempRootsDir = Data.Text.unpack $ mconcat [ Data.Text.Encoding.decodeUtf8 (unStoreDir storeDir), "/../var/nix/temproots/" ]
|
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 <-
|
tempRootList <-
|
||||||
liftIO
|
System.Directory.listDirectory tempRootsDir
|
||||||
$ System.Directory.listDirectory
|
forM_ tempRootList $ \entry -> do
|
||||||
tempRootsDir
|
|
||||||
liftIO $ forM_ tempRootList $ \entry -> do
|
|
||||||
System.Directory.removeFile
|
System.Directory.removeFile
|
||||||
$ mconcat [ tempRootsDir, "/", entry ]
|
$ 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{..} <-
|
GCResult{..} <-
|
||||||
collectGarbage
|
collectGarbage
|
||||||
GCOptions
|
GCOptions
|
||||||
{ gcOptionsOperation = GCAction_DeleteSpecific
|
{ gcOptionsOperation = GCAction_DeleteSpecific
|
||||||
, gcOptionsIgnoreLiveness = False
|
, gcOptionsIgnoreLiveness = False
|
||||||
, gcOptionsPathsToDelete = Data.HashSet.fromList [path]
|
, gcOptionsPathsToDelete = Data.HashSet.fromList [path]
|
||||||
, gcOptionsMaxFreed = maxBound
|
, gcOptionsMaxFreed = maxBound
|
||||||
}
|
}
|
||||||
gcResultDeletedPaths `shouldBe` Data.HashSet.fromList [path]
|
gcResultDeletedPaths `shouldBe` Data.HashSet.fromList [path]
|
||||||
gcResultBytesFreed `shouldBe` 4
|
gcResultBytesFreed `shouldBe` 4
|
||||||
|
@ -17,7 +17,7 @@ import System.Nix.Store.Remote.Arbitrary ()
|
|||||||
import System.Nix.Store.Remote.Serializer
|
import System.Nix.Store.Remote.Serializer
|
||||||
import System.Nix.Store.Remote.Types.Logger (Logger(..))
|
import System.Nix.Store.Remote.Types.Logger (Logger(..))
|
||||||
import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..))
|
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(..))
|
import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..))
|
||||||
|
|
||||||
-- | Test for roundtrip using @NixSerializer@
|
-- | Test for roundtrip using @NixSerializer@
|
||||||
@ -71,7 +71,7 @@ spec = parallel $ do
|
|||||||
prop "< 1.28"
|
prop "< 1.28"
|
||||||
$ \sd -> forAll (arbitrary `suchThat` ((< 28) . protoVersion_minor))
|
$ \sd -> forAll (arbitrary `suchThat` ((< 28) . protoVersion_minor))
|
||||||
$ \pv ->
|
$ \pv ->
|
||||||
roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd pv)
|
roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd pv)
|
||||||
. (\x -> x { buildResultBuiltOutputs = Nothing })
|
. (\x -> x { buildResultBuiltOutputs = Nothing })
|
||||||
. (\x -> x { buildResultTimesBuilt = Nothing
|
. (\x -> x { buildResultTimesBuilt = Nothing
|
||||||
, buildResultIsNonDeterministic = Nothing
|
, buildResultIsNonDeterministic = Nothing
|
||||||
@ -81,7 +81,7 @@ spec = parallel $ do
|
|||||||
)
|
)
|
||||||
prop "= 1.28"
|
prop "= 1.28"
|
||||||
$ \sd ->
|
$ \sd ->
|
||||||
roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd (ProtoVersion 1 28))
|
roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd (ProtoVersion 1 28))
|
||||||
. (\x -> x { buildResultTimesBuilt = Nothing
|
. (\x -> x { buildResultTimesBuilt = Nothing
|
||||||
, buildResultIsNonDeterministic = Nothing
|
, buildResultIsNonDeterministic = Nothing
|
||||||
, buildResultStartTime = Nothing
|
, buildResultStartTime = Nothing
|
||||||
@ -91,7 +91,7 @@ spec = parallel $ do
|
|||||||
prop "> 1.28"
|
prop "> 1.28"
|
||||||
$ \sd -> forAll (arbitrary `suchThat` ((> 28) . protoVersion_minor))
|
$ \sd -> forAll (arbitrary `suchThat` ((> 28) . protoVersion_minor))
|
||||||
$ \pv ->
|
$ \pv ->
|
||||||
roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd pv)
|
roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd pv)
|
||||||
|
|
||||||
prop "StorePath" $
|
prop "StorePath" $
|
||||||
roundtripSReader @StoreDir storePath
|
roundtripSReader @StoreDir storePath
|
||||||
@ -147,7 +147,7 @@ spec = parallel $ do
|
|||||||
prop "StoreRequest"
|
prop "StoreRequest"
|
||||||
$ \testStoreConfig ->
|
$ \testStoreConfig ->
|
||||||
forAll (arbitrary `suchThat` (restrictProtoVersion (hasProtoVersion testStoreConfig)))
|
forAll (arbitrary `suchThat` (restrictProtoVersion (hasProtoVersion testStoreConfig)))
|
||||||
$ roundtripSReader @TestStoreConfig storeRequest testStoreConfig
|
$ roundtripSReader @ProtoStoreConfig storeRequest testStoreConfig
|
||||||
|
|
||||||
describe "StoreReply" $ do
|
describe "StoreReply" $ do
|
||||||
prop "()" $ roundtripS opSuccess
|
prop "()" $ roundtripS opSuccess
|
||||||
|
Loading…
Reference in New Issue
Block a user