{-# 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
-- 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 = 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 -- 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])))
-> 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)