{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module System.Nix.Store.Remote.Protocol (
WorkerOp(..)
, simpleOp
, simpleOpArgs
, runOp
, runOpArgs
, runOpArgsIO
, runStore
, runStoreOpts) where
import Control.Exception (bracket)
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString
import qualified Data.ByteString.Char8
import qualified Data.ByteString.Lazy
import Network.Socket (SockAddr(SockAddrUnix))
import qualified Network.Socket
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 = do
WorkerOp -> Put -> MonadStore Bool
simpleOpArgs WorkerOp
op (Put -> MonadStore Bool) -> Put -> MonadStore Bool
forall a b. (a -> b) -> a -> b
$ () -> Put
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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
case Bool
err of
Bool
True -> do
Error Int
_num ByteString
msg <- [Logger] -> Logger
forall a. [a] -> a
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
False -> do
MonadStore Bool
sockGetBool
runOp :: WorkerOp -> MonadStore ()
runOp :: WorkerOp -> MonadStore ()
runOp WorkerOp
op = WorkerOp -> Put -> MonadStore ()
runOpArgs WorkerOp
op (Put -> MonadStore ()) -> Put -> MonadStore ()
forall a b. (a -> b) -> a -> b
$ () -> Put
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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
Data.ByteString.Lazy.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
$ do
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
storeSocket (StoreConfig -> Socket)
-> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
StoreConfig
-> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
Socket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
StoreConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
(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. [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
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
sockPath String
storeRootDir MonadStore a
code = do
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 (String -> IO StoreConfig
open String
sockPath) (Socket -> IO ()
Network.Socket.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 :: String -> IO StoreConfig
open String
path = do
Socket
soc <-
Family -> SocketType -> ProtocolNumber -> IO Socket
Network.Socket.socket
Family
Network.Socket.AF_UNIX
SocketType
Network.Socket.Stream
ProtocolNumber
0
Socket -> SockAddr -> IO ()
Network.Socket.connect Socket
soc (String -> SockAddr
SockAddrUnix String
path)
StoreConfig -> IO StoreConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (StoreConfig -> IO StoreConfig) -> StoreConfig -> IO StoreConfig
forall a b. (a -> b) -> a -> b
$ 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
storeSocket (StoreConfig -> Socket)
-> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
StoreConfig
-> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
Socket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT
String
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
StoreConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
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
Data.ByteString.Lazy.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
$ String -> MonadStore ()
forall a. HasCallStack => String -> a
error String
"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])))
-> StoreConfig
-> ReaderT
StoreConfig IO (Either String a, (Maybe ByteString, [Logger]))
-> IO (Either String a, (Maybe ByteString, [Logger]))
forall a b c. (a -> b -> c) -> b -> a -> c
flip 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])))
-> (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 c. (a -> b -> c) -> b -> a -> c
flip 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)