{-# 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
-- 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
$c== :: WorkerOp -> WorkerOp -> Bool
== :: WorkerOp -> WorkerOp -> Bool
$c/= :: WorkerOp -> WorkerOp -> Bool
/= :: 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
$ccompare :: WorkerOp -> WorkerOp -> Ordering
compare :: WorkerOp -> WorkerOp -> Ordering
$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
>= :: WorkerOp -> WorkerOp -> Bool
$cmax :: WorkerOp -> WorkerOp -> WorkerOp
max :: WorkerOp -> WorkerOp -> WorkerOp
$cmin :: WorkerOp -> WorkerOp -> WorkerOp
min :: WorkerOp -> WorkerOp -> 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
$cshowsPrec :: Int -> WorkerOp -> ShowS
showsPrec :: Int -> WorkerOp -> ShowS
$cshow :: WorkerOp -> String
show :: WorkerOp -> String
$cshowList :: [WorkerOp] -> ShowS
showList :: [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
  err <- MonadStore Bool
gotError
  bool
    sockGetBool
    (do
      Error _num msg <- Unsafe.head <$> getError
      throwError $ Data.ByteString.Char8.unpack msg
    )
    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

  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
  encoder (liftIO . sendAll soc)

  out <- processOutput
  modify (\(Maybe ByteString
a, [Logger]
b) -> (Maybe ByteString
a, [Logger]
b [Logger] -> [Logger] -> [Logger]
forall a. Semigroup a => a -> a -> a
<> [Logger]
out))
  err <- gotError
  when err $ do
    Error _num msg <- Unsafe.head <$> getError
    throwError $ Data.ByteString.Char8.unpack msg

runStore :: MonadStore a -> IO (Either String a, [Logger])
runStore :: forall a. 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 :: forall a.
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 :: forall a.
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]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo -> Maybe String -> Maybe String -> IO (t 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 a b. IO a -> (a -> IO b) -> IO b
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 a. a -> IO a
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' :: forall a.
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
    soc <- Family -> SocketType -> ProtocolNumber -> IO Socket
S.socket Family
sockFamily SocketType
S.Stream ProtocolNumber
0
    S.connect soc sockAddr
    pure StoreConfig
        { storeSocket = soc
        , storeDir = 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
    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
    vermagic <- liftIO $ recv soc 16
    let
      (magic2, _daemonProtoVersion) =
        flip runGet (fromStrict vermagic)
          $ (,)
            <$> (getInt :: Get Int)
            <*> (getInt :: Get Int)
    unless (magic2 == workerMagic2) $ error "Worker magic 2 mismatch"

    sockPut $ putInt protoVersion -- clientVersion
    sockPut $ putInt (0 :: Int)   -- affinity
    sockPut $ putInt (0 :: Int)   -- obsolete reserveSpace

    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 a b. (a -> b) -> IO a -> IO b
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 a b.
ExceptT
  String
  (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
  a
-> ExceptT
     String
     (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
     b
-> ExceptT
     String
     (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
     b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MonadStore a
code)