{-# language DataKinds #-}
{-# language ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
module System.Nix.Store.Remote.Protocol
( WorkerOp(..)
, simpleOp
, simpleOpArgs
, runOp
, runOpArgs
, runOpArgsIO
, runStore
, runStoreOpts
, runStoreOptsTCP
, runStoreOpts'
)
where
import qualified Relude.Unsafe as Unsafe
import Control.Exception ( bracket )
import Control.Monad.Except
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString
import qualified Data.ByteString.Char8
import Network.Socket ( SockAddr(SockAddrUnix) )
import qualified Network.Socket as S
import Network.Socket.ByteString ( recv
, sendAll
)
import System.Nix.Store.Remote.Binary
import System.Nix.Store.Remote.Logger
import System.Nix.Store.Remote.Types
import System.Nix.Store.Remote.Util
protoVersion :: Int
protoVersion :: Int
protoVersion = Int
0x115
workerMagic1 :: Int
workerMagic1 :: Int
workerMagic1 = Int
0x6e697863
workerMagic2 :: Int
workerMagic2 :: Int
workerMagic2 = Int
0x6478696f
defaultSockPath :: String
defaultSockPath :: String
defaultSockPath = String
"/nix/var/nix/daemon-socket/socket"
data WorkerOp =
IsValidPath
| HasSubstitutes
| QueryReferrers
| AddToStore
| AddTextToStore
| BuildPaths
| EnsurePath
| AddTempRoot
| AddIndirectRoot
| SyncWithGC
| FindRoots
| SetOptions
| CollectGarbage
| QuerySubstitutablePathInfo
| QueryDerivationOutputs
| QueryAllValidPaths
| QueryFailedPaths
| ClearFailedPaths
| QueryPathInfo
| QueryDerivationOutputNames
| QueryPathFromHashPart
| QuerySubstitutablePathInfos
| QueryValidPaths
| QuerySubstitutablePaths
| QueryValidDerivers
| OptimiseStore
| VerifyStore
| BuildDerivation
| AddSignatures
| NarFromPath
| AddToStoreNar
| QueryMissing
deriving (WorkerOp -> WorkerOp -> Bool
(WorkerOp -> WorkerOp -> Bool)
-> (WorkerOp -> WorkerOp -> Bool) -> Eq WorkerOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WorkerOp -> WorkerOp -> Bool
$c/= :: WorkerOp -> WorkerOp -> Bool
== :: WorkerOp -> WorkerOp -> Bool
$c== :: WorkerOp -> WorkerOp -> Bool
Eq, Eq WorkerOp
Eq WorkerOp
-> (WorkerOp -> WorkerOp -> Ordering)
-> (WorkerOp -> WorkerOp -> Bool)
-> (WorkerOp -> WorkerOp -> Bool)
-> (WorkerOp -> WorkerOp -> Bool)
-> (WorkerOp -> WorkerOp -> Bool)
-> (WorkerOp -> WorkerOp -> WorkerOp)
-> (WorkerOp -> WorkerOp -> WorkerOp)
-> Ord WorkerOp
WorkerOp -> WorkerOp -> Bool
WorkerOp -> WorkerOp -> Ordering
WorkerOp -> WorkerOp -> WorkerOp
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: WorkerOp -> WorkerOp -> WorkerOp
$cmin :: WorkerOp -> WorkerOp -> WorkerOp
max :: WorkerOp -> WorkerOp -> WorkerOp
$cmax :: WorkerOp -> WorkerOp -> WorkerOp
>= :: WorkerOp -> WorkerOp -> Bool
$c>= :: WorkerOp -> WorkerOp -> Bool
> :: WorkerOp -> WorkerOp -> Bool
$c> :: WorkerOp -> WorkerOp -> Bool
<= :: WorkerOp -> WorkerOp -> Bool
$c<= :: WorkerOp -> WorkerOp -> Bool
< :: WorkerOp -> WorkerOp -> Bool
$c< :: WorkerOp -> WorkerOp -> Bool
compare :: WorkerOp -> WorkerOp -> Ordering
$ccompare :: WorkerOp -> WorkerOp -> Ordering
$cp1Ord :: Eq WorkerOp
Ord, Int -> WorkerOp -> ShowS
[WorkerOp] -> ShowS
WorkerOp -> String
(Int -> WorkerOp -> ShowS)
-> (WorkerOp -> String) -> ([WorkerOp] -> ShowS) -> Show WorkerOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WorkerOp] -> ShowS
$cshowList :: [WorkerOp] -> ShowS
show :: WorkerOp -> String
$cshow :: WorkerOp -> String
showsPrec :: Int -> WorkerOp -> ShowS
$cshowsPrec :: Int -> WorkerOp -> ShowS
Show)
opNum :: WorkerOp -> Int
opNum :: WorkerOp -> Int
opNum WorkerOp
IsValidPath = Int
1
opNum WorkerOp
HasSubstitutes = Int
3
opNum WorkerOp
QueryReferrers = Int
6
opNum WorkerOp
AddToStore = Int
7
opNum WorkerOp
AddTextToStore = Int
8
opNum WorkerOp
BuildPaths = Int
9
opNum WorkerOp
EnsurePath = Int
10
opNum WorkerOp
AddTempRoot = Int
11
opNum WorkerOp
AddIndirectRoot = Int
12
opNum WorkerOp
SyncWithGC = Int
13
opNum WorkerOp
FindRoots = Int
14
opNum WorkerOp
SetOptions = Int
19
opNum WorkerOp
CollectGarbage = Int
20
opNum WorkerOp
QuerySubstitutablePathInfo = Int
21
opNum WorkerOp
QueryDerivationOutputs = Int
22
opNum WorkerOp
QueryAllValidPaths = Int
23
opNum WorkerOp
QueryFailedPaths = Int
24
opNum WorkerOp
ClearFailedPaths = Int
25
opNum WorkerOp
QueryPathInfo = Int
26
opNum WorkerOp
QueryDerivationOutputNames = Int
28
opNum WorkerOp
QueryPathFromHashPart = Int
29
opNum WorkerOp
QuerySubstitutablePathInfos = Int
30
opNum WorkerOp
QueryValidPaths = Int
31
opNum WorkerOp
QuerySubstitutablePaths = Int
32
opNum WorkerOp
QueryValidDerivers = Int
33
opNum WorkerOp
OptimiseStore = Int
34
opNum WorkerOp
VerifyStore = Int
35
opNum WorkerOp
BuildDerivation = Int
36
opNum WorkerOp
AddSignatures = Int
37
opNum WorkerOp
NarFromPath = Int
38
opNum WorkerOp
AddToStoreNar = Int
39
opNum WorkerOp
QueryMissing = Int
40
simpleOp :: WorkerOp -> MonadStore Bool
simpleOp :: WorkerOp -> MonadStore Bool
simpleOp WorkerOp
op = WorkerOp -> Put -> MonadStore Bool
simpleOpArgs WorkerOp
op Put
forall (f :: * -> *). Applicative f => f ()
pass
simpleOpArgs :: WorkerOp -> Put -> MonadStore Bool
simpleOpArgs :: WorkerOp -> Put -> MonadStore Bool
simpleOpArgs WorkerOp
op Put
args = do
WorkerOp -> Put -> MonadStore ()
runOpArgs WorkerOp
op Put
args
Bool
err <- MonadStore Bool
gotError
MonadStore Bool -> MonadStore Bool -> Bool -> MonadStore Bool
forall a. a -> a -> Bool -> a
bool
MonadStore Bool
sockGetBool
(do
Error Int
_num ByteString
msg <- [Logger] -> Logger
forall a. [a] -> a
Unsafe.head ([Logger] -> Logger)
-> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
[Logger]
-> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
[Logger]
getError
String -> MonadStore Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> MonadStore Bool) -> String -> MonadStore Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> String
Data.ByteString.Char8.unpack ByteString
msg
)
Bool
err
runOp :: WorkerOp -> MonadStore ()
runOp :: WorkerOp -> MonadStore ()
runOp WorkerOp
op = WorkerOp -> Put -> MonadStore ()
runOpArgs WorkerOp
op Put
forall (f :: * -> *). Applicative f => f ()
pass
runOpArgs :: WorkerOp -> Put -> MonadStore ()
runOpArgs :: WorkerOp -> Put -> MonadStore ()
runOpArgs WorkerOp
op Put
args =
WorkerOp
-> ((ByteString -> MonadStore ()) -> MonadStore ())
-> MonadStore ()
runOpArgsIO
WorkerOp
op
(\ByteString -> MonadStore ()
encode -> ByteString -> MonadStore ()
encode (ByteString -> MonadStore ()) -> ByteString -> MonadStore ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
forall l s. LazyStrict l s => l -> s
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPut Put
args)
runOpArgsIO
:: WorkerOp
-> ((Data.ByteString.ByteString -> MonadStore ()) -> MonadStore ())
-> MonadStore ()
runOpArgsIO :: WorkerOp
-> ((ByteString -> MonadStore ()) -> MonadStore ())
-> MonadStore ()
runOpArgsIO WorkerOp
op (ByteString -> MonadStore ()) -> MonadStore ()
encoder = do
Put -> MonadStore ()
sockPut (Put -> MonadStore ()) -> Put -> MonadStore ()
forall a b. (a -> b) -> a -> b
$ Int -> Put
forall a. Integral a => a -> Put
putInt (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ WorkerOp -> Int
opNum WorkerOp
op
Socket
soc <- (StoreConfig -> Socket)
-> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
Socket
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks StoreConfig -> Socket
storeSocket
(ByteString -> MonadStore ()) -> MonadStore ()
encoder (IO () -> MonadStore ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MonadStore ())
-> (ByteString -> IO ()) -> ByteString -> MonadStore ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> ByteString -> IO ()
sendAll Socket
soc)
[Logger]
out <- ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
[Logger]
processOutput
((Maybe ByteString, [Logger]) -> (Maybe ByteString, [Logger]))
-> MonadStore ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\(Maybe ByteString
a, [Logger]
b) -> (Maybe ByteString
a, [Logger]
b [Logger] -> [Logger] -> [Logger]
forall a. Semigroup a => a -> a -> a
<> [Logger]
out))
Bool
err <- MonadStore Bool
gotError
Bool -> MonadStore () -> MonadStore ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
err (MonadStore () -> MonadStore ()) -> MonadStore () -> MonadStore ()
forall a b. (a -> b) -> a -> b
$ do
Error Int
_num ByteString
msg <- [Logger] -> Logger
forall a. [a] -> a
Unsafe.head ([Logger] -> Logger)
-> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
[Logger]
-> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
[Logger]
getError
String -> MonadStore ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> MonadStore ()) -> String -> MonadStore ()
forall a b. (a -> b) -> a -> b
$ ByteString -> String
Data.ByteString.Char8.unpack ByteString
msg
runStore :: MonadStore a -> IO (Either String a, [Logger])
runStore :: MonadStore a -> IO (Either String a, [Logger])
runStore = String -> String -> MonadStore a -> IO (Either String a, [Logger])
forall a.
String -> String -> MonadStore a -> IO (Either String a, [Logger])
runStoreOpts String
defaultSockPath String
"/nix/store"
runStoreOpts
:: FilePath -> FilePath -> MonadStore a -> IO (Either String a, [Logger])
runStoreOpts :: String -> String -> MonadStore a -> IO (Either String a, [Logger])
runStoreOpts String
path = Family
-> SockAddr
-> String
-> MonadStore a
-> IO (Either String a, [Logger])
forall a.
Family
-> SockAddr
-> String
-> MonadStore a
-> IO (Either String a, [Logger])
runStoreOpts' Family
S.AF_UNIX (String -> SockAddr
SockAddrUnix String
path)
runStoreOptsTCP
:: String -> Int -> FilePath -> MonadStore a -> IO (Either String a, [Logger])
runStoreOptsTCP :: String
-> Int -> String -> MonadStore a -> IO (Either String a, [Logger])
runStoreOptsTCP String
host Int
port String
storeRootDir MonadStore a
code = do
Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
S.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
S.defaultHints) (String -> Maybe String
forall a. a -> Maybe a
Just String
host) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
port) IO [AddrInfo]
-> ([AddrInfo] -> IO (Either String a, [Logger]))
-> IO (Either String a, [Logger])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(AddrInfo
sockAddr:[AddrInfo]
_) -> Family
-> SockAddr
-> String
-> MonadStore a
-> IO (Either String a, [Logger])
forall a.
Family
-> SockAddr
-> String
-> MonadStore a
-> IO (Either String a, [Logger])
runStoreOpts' (AddrInfo -> Family
S.addrFamily AddrInfo
sockAddr) (AddrInfo -> SockAddr
S.addrAddress AddrInfo
sockAddr) String
storeRootDir MonadStore a
code
[AddrInfo]
_ -> (Either String a, [Logger]) -> IO (Either String a, [Logger])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String a
forall a b. a -> Either a b
Left String
"Couldn't resolve host and port with getAddrInfo.", [])
runStoreOpts'
:: S.Family -> S.SockAddr -> FilePath -> MonadStore a -> IO (Either String a, [Logger])
runStoreOpts' :: Family
-> SockAddr
-> String
-> MonadStore a
-> IO (Either String a, [Logger])
runStoreOpts' Family
sockFamily SockAddr
sockAddr String
storeRootDir MonadStore a
code =
IO StoreConfig
-> (StoreConfig -> IO ())
-> (StoreConfig -> IO (Either String a, [Logger]))
-> IO (Either String a, [Logger])
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO StoreConfig
open (Socket -> IO ()
S.close (Socket -> IO ())
-> (StoreConfig -> Socket) -> StoreConfig -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreConfig -> Socket
storeSocket) StoreConfig -> IO (Either String a, [Logger])
run
where
open :: IO StoreConfig
open = do
Socket
soc <- Family -> SocketType -> ProtocolNumber -> IO Socket
S.socket Family
sockFamily SocketType
S.Stream ProtocolNumber
0
Socket -> SockAddr -> IO ()
S.connect Socket
soc SockAddr
sockAddr
StoreConfig -> IO StoreConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure StoreConfig :: String -> Socket -> StoreConfig
StoreConfig
{ storeSocket :: Socket
storeSocket = Socket
soc
, storeDir :: String
storeDir = String
storeRootDir
}
greet :: ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
[Logger]
greet = do
Put -> MonadStore ()
sockPut (Put -> MonadStore ()) -> Put -> MonadStore ()
forall a b. (a -> b) -> a -> b
$ Int -> Put
forall a. Integral a => a -> Put
putInt Int
workerMagic1
Socket
soc <- (StoreConfig -> Socket)
-> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
Socket
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks StoreConfig -> Socket
storeSocket
ByteString
vermagic <- IO ByteString
-> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString
-> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
ByteString)
-> IO ByteString
-> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
ByteString
forall a b. (a -> b) -> a -> b
$ Socket -> Int -> IO ByteString
recv Socket
soc Int
16
let
(Int
magic2, Int
_daemonProtoVersion) =
(Get (Int, Int) -> ByteString -> (Int, Int))
-> ByteString -> Get (Int, Int) -> (Int, Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Get (Int, Int) -> ByteString -> (Int, Int)
forall a. Get a -> ByteString -> a
runGet (ByteString -> ByteString
forall l s. LazyStrict l s => s -> l
fromStrict ByteString
vermagic)
(Get (Int, Int) -> (Int, Int)) -> Get (Int, Int) -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ (,)
(Int -> Int -> (Int, Int)) -> Get Int -> Get (Int -> (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get Int
forall a. Integral a => Get a
getInt :: Get Int)
Get (Int -> (Int, Int)) -> Get Int -> Get (Int, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Get Int
forall a. Integral a => Get a
getInt :: Get Int)
Bool -> MonadStore () -> MonadStore ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
magic2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
workerMagic2) (MonadStore () -> MonadStore ()) -> MonadStore () -> MonadStore ()
forall a b. (a -> b) -> a -> b
$ Text -> MonadStore ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Worker magic 2 mismatch"
Put -> MonadStore ()
sockPut (Put -> MonadStore ()) -> Put -> MonadStore ()
forall a b. (a -> b) -> a -> b
$ Int -> Put
forall a. Integral a => a -> Put
putInt Int
protoVersion
Put -> MonadStore ()
sockPut (Put -> MonadStore ()) -> Put -> MonadStore ()
forall a b. (a -> b) -> a -> b
$ Int -> Put
forall a. Integral a => a -> Put
putInt (Int
0 :: Int)
Put -> MonadStore ()
sockPut (Put -> MonadStore ()) -> Put -> MonadStore ()
forall a b. (a -> b) -> a -> b
$ Int -> Put
forall a. Integral a => a -> Put
putInt (Int
0 :: Int)
ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
[Logger]
processOutput
run :: StoreConfig -> IO (Either String a, [Logger])
run StoreConfig
sock =
((Either String a, (Maybe ByteString, [Logger]))
-> (Either String a, [Logger]))
-> IO (Either String a, (Maybe ByteString, [Logger]))
-> IO (Either String a, [Logger])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Either String a
res, (Maybe ByteString
_data, [Logger]
logs)) -> (Either String a
res, [Logger]
logs))
(IO (Either String a, (Maybe ByteString, [Logger]))
-> IO (Either String a, [Logger]))
-> IO (Either String a, (Maybe ByteString, [Logger]))
-> IO (Either String a, [Logger])
forall a b. (a -> b) -> a -> b
$ (ReaderT
StoreConfig IO (Either String a, (Maybe ByteString, [Logger]))
-> StoreConfig
-> IO (Either String a, (Maybe ByteString, [Logger]))
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` StoreConfig
sock)
(ReaderT
StoreConfig IO (Either String a, (Maybe ByteString, [Logger]))
-> IO (Either String a, (Maybe ByteString, [Logger])))
-> ReaderT
StoreConfig IO (Either String a, (Maybe ByteString, [Logger]))
-> IO (Either String a, (Maybe ByteString, [Logger]))
forall a b. (a -> b) -> a -> b
$ (StateT
(Maybe ByteString, [Logger])
(ReaderT StoreConfig IO)
(Either String a)
-> (Maybe ByteString, [Logger])
-> ReaderT
StoreConfig IO (Either String a, (Maybe ByteString, [Logger]))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
`runStateT` (Maybe ByteString
forall a. Maybe a
Nothing, []))
(StateT
(Maybe ByteString, [Logger])
(ReaderT StoreConfig IO)
(Either String a)
-> ReaderT
StoreConfig IO (Either String a, (Maybe ByteString, [Logger])))
-> StateT
(Maybe ByteString, [Logger])
(ReaderT StoreConfig IO)
(Either String a)
-> ReaderT
StoreConfig IO (Either String a, (Maybe ByteString, [Logger]))
forall a b. (a -> b) -> a -> b
$ MonadStore a
-> StateT
(Maybe ByteString, [Logger])
(ReaderT StoreConfig IO)
(Either String a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
[Logger]
greet ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
[Logger]
-> MonadStore a -> MonadStore a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MonadStore a
code)