{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module System.Nix.Store.Remote.Protocol
  ( WorkerOp(..)
  , simpleOp
  , simpleOpArgs
  , runOp
  , runOpArgs
  , runOpArgsIO
  , runStore
  , runStoreOpts
  )
where


import           Data.Bool                      ( bool )
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
-- major protoVersion & 0xFF00
-- minor ..           & 0x00FF

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 -> MonadStore Bool) -> Put -> MonadStore Bool
forall a b. (a -> b) -> a -> b
$ () -> Put
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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
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 -> MonadStore ()) -> Put -> MonadStore ()
forall a b. (a -> b) -> a -> b
$ () -> Put
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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
$ 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
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 (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
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 -- clientVersion
    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)   -- affinity
    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)   -- obsolete reserveSpace

    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)