{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
module System.Nix.Store.Remote.Server
  ( runProxyDaemon
  , WorkerHelper
  )
  where

import Control.Concurrent.Classy.Async
import Control.Monad (join, void, when)
import Control.Monad.Conc.Class (MonadConc)
import Control.Monad.Except (MonadError, throwError)
import Control.Monad.Trans (lift)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Default.Class (Default(def))
import Data.Foldable (traverse_)
import Data.IORef (IORef, atomicModifyIORef, newIORef)
import Data.Text (Text)
import Data.Void (Void, absurd)
import Data.Word (Word32)
import Network.Socket (Socket, accept, close, listen, maxListenQueue)
import System.Nix.Nar (NarSource)
import System.Nix.Store.Remote.Client (Run, doReq)
import System.Nix.Store.Remote.Serializer (LoggerSError, mapErrorS, storeRequest, workerMagic, protoVersion, int, logger, text, trustedFlag)
import System.Nix.Store.Remote.Socket
import System.Nix.Store.Remote.Types.StoreRequest as R
import System.Nix.Store.Remote.Types.StoreReply
import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..))
import System.Nix.Store.Remote.Types.Logger (BasicError(..), ErrorInfo, Logger(..))
import System.Nix.Store.Remote.MonadStore (MonadRemoteStore(..), WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT)
import System.Nix.Store.Remote.Types.Handshake (ServerHandshakeInput(..), ServerHandshakeOutput(..))
import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))
import qualified Data.Some
import qualified Data.Text
import qualified Data.Text.IO
import qualified System.Timeout
import qualified Network.Socket.ByteString

type WorkerHelper m
  = forall a
  . ( Show a
    , StoreReply a
    )
  => RemoteStoreT m a
  -> Run m a

chatty :: Bool
chatty :: Bool
chatty = Bool
False

dbg :: MonadIO m => Text -> m ()
dbg :: forall (m :: * -> *). MonadIO m => Text -> m ()
dbg = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
chatty (m () -> m ()) -> (Text -> m ()) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
Data.Text.IO.putStrLn

-- | Run an emulated nix daemon on given socket address.
-- The deamon will close when the continuation returns.
runProxyDaemon
  :: forall m a
  . ( MonadIO m
    , MonadConc m
    )
  => WorkerHelper m
  -> RemoteStoreT m ()
  -> Socket
  -> m a
  -> m a
runProxyDaemon :: forall (m :: * -> *) a.
(MonadIO m, MonadConc m) =>
WorkerHelper m -> RemoteStoreT m () -> Socket -> m a -> m a
runProxyDaemon WorkerHelper m
workerHelper RemoteStoreT m ()
postGreet Socket
lsock m a
k = do
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Socket -> Int -> IO ()
listen Socket
lsock Int
maxListenQueue

  Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
dbg Text
"listening"

  let listener :: m Void
      listener :: m Void
listener = do
        (Socket
sock, SockAddr
_) <- IO (Socket, SockAddr) -> m (Socket, SockAddr)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Socket, SockAddr) -> m (Socket, SockAddr))
-> IO (Socket, SockAddr) -> m (Socket, SockAddr)
forall a b. (a -> b) -> a -> b
$ Socket -> IO (Socket, SockAddr)
accept Socket
lsock
        Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
dbg Text
"accepting"

        -- TODO: this, but without the space leak
        ((Void, ()) -> Void) -> m (Void, ()) -> m Void
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Void, ()) -> Void
forall a b. (a, b) -> a
fst
          (m (Void, ()) -> m Void) -> m (Void, ()) -> m Void
forall a b. (a -> b) -> a -> b
$ m Void -> m () -> m (Void, ())
forall (m :: * -> *) a b. MonadConc m => m a -> m b -> m (a, b)
concurrently m Void
listener
          (m () -> m (Void, ())) -> m () -> m (Void, ())
forall a b. (a -> b) -> a -> b
$ WorkerHelper m -> RemoteStoreT m () -> Socket -> m ()
forall (m :: * -> *).
MonadIO m =>
WorkerHelper m -> RemoteStoreT m () -> Socket -> m ()
processConnection RemoteStoreT m a -> Run m a
WorkerHelper m
workerHelper RemoteStoreT m ()
postGreet Socket
sock

  (Void -> a) -> (a -> a) -> Either Void a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Void -> a
forall a. Void -> a
absurd a -> a
forall a. a -> a
id (Either Void a -> a) -> m (Either Void a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Void -> m a -> m (Either Void a)
forall (m :: * -> *) a b.
MonadConc m =>
m a -> m b -> m (Either a b)
race m Void
listener m a
k

-- | "main loop" of the daemon for a single connection.
--
-- this function should take care to not throw errors from client connections.
processConnection
  :: forall m
  .  MonadIO m
  => WorkerHelper m
  -> RemoteStoreT m ()
  -> Socket
  -> m ()
processConnection :: forall (m :: * -> *).
MonadIO m =>
WorkerHelper m -> RemoteStoreT m () -> Socket -> m ()
processConnection WorkerHelper m
workerHelper RemoteStoreT m ()
postGreet Socket
sock = do
  ~() <- m (Either RemoteStoreError Any, DList Logger) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Either RemoteStoreError Any, DList Logger) -> m ())
-> m (Either RemoteStoreError Any, DList Logger) -> m ()
forall a b. (a -> b) -> a -> b
$ Socket
-> RemoteStoreT m Any
-> m (Either RemoteStoreError Any, DList Logger)
forall (m :: * -> *) a.
Monad m =>
Socket
-> RemoteStoreT m a -> m (Either RemoteStoreError a, DList Logger)
runRemoteStoreT Socket
sock (RemoteStoreT m Any
 -> m (Either RemoteStoreError Any, DList Logger))
-> RemoteStoreT m Any
-> m (Either RemoteStoreError Any, DList Logger)
forall a b. (a -> b) -> a -> b
$ do

    ServerHandshakeOutput{ProtoVersion
serverHandshakeOutputLeastCommonVersion :: ProtoVersion
serverHandshakeOutputClientVersion :: ProtoVersion
serverHandshakeOutputLeastCommonVersion :: ServerHandshakeOutput -> ProtoVersion
serverHandshakeOutputClientVersion :: ServerHandshakeOutput -> ProtoVersion
..}
      <- MonadIO m =>
ServerHandshakeInput -> RemoteStoreT m ServerHandshakeOutput
ServerHandshakeInput -> RemoteStoreT m ServerHandshakeOutput
greet
          ServerHandshakeInput
          { serverHandshakeInputNixVersion :: Text
serverHandshakeInputNixVersion = Text
"nixVersion (hnix-store-remote)"
          , serverHandshakeInputOurVersion :: ProtoVersion
serverHandshakeInputOurVersion = ProtoVersion
forall a. Default a => a
def
          , serverHandshakeInputTrust :: Maybe TrustedFlag
serverHandshakeInputTrust = Maybe TrustedFlag
forall a. Maybe a
Nothing
          }

    ProtoVersion -> RemoteStoreT m ()
forall (m :: * -> *). MonadRemoteStore m => ProtoVersion -> m ()
setProtoVersion ProtoVersion
serverHandshakeOutputLeastCommonVersion

    TunnelLogger
tunnelLogger <- IO TunnelLogger -> RemoteStoreT m TunnelLogger
forall a. IO a -> RemoteStoreT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TunnelLogger -> RemoteStoreT m TunnelLogger)
-> IO TunnelLogger -> RemoteStoreT m TunnelLogger
forall a b. (a -> b) -> a -> b
$ IO TunnelLogger
newTunnelLogger
    -- Send startup error messages to the client.
    TunnelLogger -> RemoteStoreT m ()
forall (m :: * -> *). MonadRemoteStore m => TunnelLogger -> m ()
startWork TunnelLogger
tunnelLogger

    -- TODO: do we need auth at all? probably?
    -- If we can't accept clientVersion, then throw an error *here* (not above).
    --authHook(*store);
    TunnelLogger -> RemoteStoreT m ()
forall (m :: * -> *). MonadRemoteStore m => TunnelLogger -> m ()
stopWork TunnelLogger
tunnelLogger

    -- so we can set store dir
    RemoteStoreT m ()
postGreet

    let perform
          :: ( Show a
             , StoreReply a
             )
          => StoreRequest a
          -> RemoteStoreT m ()
        perform :: forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
req = do

          RemoteStoreT m ()
special <- case StoreRequest a
req of
            AddToStore {} -> do
              -- This is a hack (but a pretty neat and fast one!)
              -- it should parse nad stream NAR instead
              let proxyNarSource :: NarSource IO
                  proxyNarSource :: NarSource IO
proxyNarSource ByteString -> IO ()
f =
                    IO (Maybe ByteString) -> IO (Maybe ByteString)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                      (Int -> IO ByteString -> IO (Maybe ByteString)
forall a. Int -> IO a -> IO (Maybe a)
System.Timeout.timeout
                         Int
1000000
                         (Socket -> Int -> IO ByteString
Network.Socket.ByteString.recv Socket
sock Int
8)
                      )
                    IO (Maybe ByteString) -> (Maybe ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                      Maybe ByteString
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                      Just ByteString
x -> ByteString -> IO ()
f ByteString
x IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> NarSource IO
proxyNarSource ByteString -> IO ()
f

              RemoteStoreT m () -> RemoteStoreT m (RemoteStoreT m ())
forall a. a -> RemoteStoreT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RemoteStoreT m () -> RemoteStoreT m (RemoteStoreT m ()))
-> RemoteStoreT m () -> RemoteStoreT m (RemoteStoreT m ())
forall a b. (a -> b) -> a -> b
$ NarSource IO -> RemoteStoreT m ()
forall (m :: * -> *). MonadRemoteStore m => NarSource IO -> m ()
setNarSource NarSource IO
proxyNarSource
            StoreRequest a
_ -> RemoteStoreT m () -> RemoteStoreT m (RemoteStoreT m ())
forall a. a -> RemoteStoreT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RemoteStoreT m () -> RemoteStoreT m (RemoteStoreT m ()))
-> RemoteStoreT m () -> RemoteStoreT m (RemoteStoreT m ())
forall a b. (a -> b) -> a -> b
$ () -> RemoteStoreT m ()
forall a. a -> RemoteStoreT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

          (Either RemoteStoreError a, DList Logger)
res <-
            TunnelLogger
-> RemoteStoreT m (Either RemoteStoreError a, DList Logger)
-> RemoteStoreT m (Either RemoteStoreError a, DList Logger)
forall (m :: * -> *) a.
MonadRemoteStore m =>
TunnelLogger -> m a -> m a
bracketLogger
              TunnelLogger
tunnelLogger
              (RemoteStoreT m (Either RemoteStoreError a, DList Logger)
 -> RemoteStoreT m (Either RemoteStoreError a, DList Logger))
-> RemoteStoreT m (Either RemoteStoreError a, DList Logger)
-> RemoteStoreT m (Either RemoteStoreError a, DList Logger)
forall a b. (a -> b) -> a -> b
$ m (Either RemoteStoreError a, DList Logger)
-> RemoteStoreT m (Either RemoteStoreError a, DList Logger)
forall (m :: * -> *) a. Monad m => m a -> RemoteStoreT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
              (m (Either RemoteStoreError a, DList Logger)
 -> RemoteStoreT m (Either RemoteStoreError a, DList Logger))
-> m (Either RemoteStoreError a, DList Logger)
-> RemoteStoreT m (Either RemoteStoreError a, DList Logger)
forall a b. (a -> b) -> a -> b
$ RemoteStoreT m a -> m (Either RemoteStoreError a, DList Logger)
WorkerHelper m
workerHelper
              (RemoteStoreT m a -> m (Either RemoteStoreError a, DList Logger))
-> RemoteStoreT m a -> m (Either RemoteStoreError a, DList Logger)
forall a b. (a -> b) -> a -> b
$ RemoteStoreT m ()
special RemoteStoreT m () -> RemoteStoreT m a -> RemoteStoreT m a
forall a b.
RemoteStoreT m a -> RemoteStoreT m b -> RemoteStoreT m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StoreRequest a -> RemoteStoreT m a
forall (m :: * -> *) a.
(MonadIO m, MonadRemoteStore m, StoreReply a, Show a) =>
StoreRequest a -> m a
doReq StoreRequest a
req

          case (Either RemoteStoreError a, DList Logger)
-> Either RemoteStoreError a
forall a b. (a, b) -> a
fst (Either RemoteStoreError a, DList Logger)
res of
            Left RemoteStoreError
e -> RemoteStoreError -> RemoteStoreT m ()
forall a. RemoteStoreError -> RemoteStoreT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RemoteStoreError
e
            Right a
reply ->
              NixSerializer ProtoStoreConfig RemoteStoreError a
-> a -> RemoteStoreT m ()
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m) =>
NixSerializer ProtoStoreConfig e a -> a -> m ()
sockPutS
                ((ReplySError -> RemoteStoreError)
-> NixSerializer ProtoStoreConfig ReplySError a
-> NixSerializer ProtoStoreConfig RemoteStoreError a
forall e e' r a.
(e -> e') -> NixSerializer r e a -> NixSerializer r e' a
mapErrorS
                   ReplySError -> RemoteStoreError
RemoteStoreError_SerializerReply
                   (NixSerializer ProtoStoreConfig ReplySError a
 -> NixSerializer ProtoStoreConfig RemoteStoreError a)
-> NixSerializer ProtoStoreConfig ReplySError a
-> NixSerializer ProtoStoreConfig RemoteStoreError a
forall a b. (a -> b) -> a -> b
$ NixSerializer ProtoStoreConfig ReplySError a
forall a.
StoreReply a =>
NixSerializer ProtoStoreConfig ReplySError a
getReplyS
                )
                a
reply

    -- Process client requests.
    let loop :: RemoteStoreT m Any
loop = do
          Some StoreRequest
someReq <-
            NixSerializer ProtoStoreConfig RemoteStoreError (Some StoreRequest)
-> RemoteStoreT m (Some StoreRequest)
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m, Show a, Show e) =>
NixSerializer ProtoStoreConfig e a -> m a
sockGetS
              (NixSerializer
   ProtoStoreConfig RemoteStoreError (Some StoreRequest)
 -> RemoteStoreT m (Some StoreRequest))
-> NixSerializer
     ProtoStoreConfig RemoteStoreError (Some StoreRequest)
-> RemoteStoreT m (Some StoreRequest)
forall a b. (a -> b) -> a -> b
$ (RequestSError -> RemoteStoreError)
-> NixSerializer ProtoStoreConfig RequestSError (Some StoreRequest)
-> NixSerializer
     ProtoStoreConfig RemoteStoreError (Some StoreRequest)
forall e e' r a.
(e -> e') -> NixSerializer r e a -> NixSerializer r e' a
mapErrorS
                  RequestSError -> RemoteStoreError
RemoteStoreError_SerializerRequest
                  NixSerializer ProtoStoreConfig RequestSError (Some StoreRequest)
forall r.
(HasProtoVersion r, HasStoreDir r) =>
NixSerializer r RequestSError (Some StoreRequest)
storeRequest

          -- have to be explicit here
          -- because otherwise GHC can't conjure Show a, StoreReply a
          -- out of thin air
          () <- Some StoreRequest
-> (forall {a}. StoreRequest a -> RemoteStoreT m ())
-> RemoteStoreT m ()
forall {k} (tag :: k -> *) b.
Some tag -> (forall (a :: k). tag a -> b) -> b
Data.Some.withSome Some StoreRequest
someReq ((forall {a}. StoreRequest a -> RemoteStoreT m ())
 -> RemoteStoreT m ())
-> (forall {a}. StoreRequest a -> RemoteStoreT m ())
-> RemoteStoreT m ()
forall a b. (a -> b) -> a -> b
$ \case
            r :: StoreRequest a
r@AddToStore {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@AddToStoreNar {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@AddTextToStore {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@AddSignatures {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@AddTempRoot {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@AddIndirectRoot {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@BuildDerivation {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@BuildPaths {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@CollectGarbage {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@EnsurePath {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@FindRoots {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@IsValidPath {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@NarFromPath {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@QueryValidPaths {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@QueryAllValidPaths {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@QuerySubstitutablePaths {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@QueryPathInfo {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@QueryReferrers {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@QueryValidDerivers {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@QueryDerivationOutputs {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@QueryDerivationOutputNames {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@QueryPathFromHashPart {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@QueryMissing {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@OptimiseStore {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@SyncWithGC {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
            r :: StoreRequest a
r@VerifyStore {} -> StoreRequest a -> RemoteStoreT m ()
forall a.
(Show a, StoreReply a) =>
StoreRequest a -> RemoteStoreT m ()
perform StoreRequest a
r
          RemoteStoreT m Any
loop
    RemoteStoreT m Any
loop

  Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
dbg Text
"daemon connection done"
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Socket -> IO ()
close Socket
sock

  where
    -- Exchange the greeting.
    greet
      :: MonadIO m
      => ServerHandshakeInput
      -> RemoteStoreT m ServerHandshakeOutput
    greet :: MonadIO m =>
ServerHandshakeInput -> RemoteStoreT m ServerHandshakeOutput
greet ServerHandshakeInput{Maybe TrustedFlag
Text
ProtoVersion
serverHandshakeInputNixVersion :: ServerHandshakeInput -> Text
serverHandshakeInputOurVersion :: ServerHandshakeInput -> ProtoVersion
serverHandshakeInputTrust :: ServerHandshakeInput -> Maybe TrustedFlag
serverHandshakeInputNixVersion :: Text
serverHandshakeInputOurVersion :: ProtoVersion
serverHandshakeInputTrust :: Maybe TrustedFlag
..} = do
      WorkerMagic
magic <-
        NixSerializer ProtoStoreConfig RemoteStoreError WorkerMagic
-> RemoteStoreT m WorkerMagic
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m, Show a, Show e) =>
NixSerializer ProtoStoreConfig e a -> m a
sockGetS
        (NixSerializer ProtoStoreConfig RemoteStoreError WorkerMagic
 -> RemoteStoreT m WorkerMagic)
-> NixSerializer ProtoStoreConfig RemoteStoreError WorkerMagic
-> RemoteStoreT m WorkerMagic
forall a b. (a -> b) -> a -> b
$ (HandshakeSError -> RemoteStoreError)
-> NixSerializer ProtoStoreConfig HandshakeSError WorkerMagic
-> NixSerializer ProtoStoreConfig RemoteStoreError WorkerMagic
forall e e' r a.
(e -> e') -> NixSerializer r e a -> NixSerializer r e' a
mapErrorS
            HandshakeSError -> RemoteStoreError
RemoteStoreError_SerializerHandshake
            NixSerializer ProtoStoreConfig HandshakeSError WorkerMagic
forall r. NixSerializer r HandshakeSError WorkerMagic
workerMagic

      Bool -> RemoteStoreT m () -> RemoteStoreT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WorkerMagic
magic WorkerMagic -> WorkerMagic -> Bool
forall a. Eq a => a -> a -> Bool
/= WorkerMagic
WorkerMagic_One)
        (RemoteStoreT m () -> RemoteStoreT m ())
-> RemoteStoreT m () -> RemoteStoreT m ()
forall a b. (a -> b) -> a -> b
$ RemoteStoreError -> RemoteStoreT m ()
forall a. RemoteStoreError -> RemoteStoreT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        (RemoteStoreError -> RemoteStoreT m ())
-> RemoteStoreError -> RemoteStoreT m ()
forall a b. (a -> b) -> a -> b
$ WorkerException -> RemoteStoreError
RemoteStoreError_WorkerException
            WorkerException
WorkerException_ProtocolMismatch

      NixSerializer ProtoStoreConfig RemoteStoreError WorkerMagic
-> WorkerMagic -> RemoteStoreT m ()
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m) =>
NixSerializer ProtoStoreConfig e a -> a -> m ()
sockPutS
        ((HandshakeSError -> RemoteStoreError)
-> NixSerializer ProtoStoreConfig HandshakeSError WorkerMagic
-> NixSerializer ProtoStoreConfig RemoteStoreError WorkerMagic
forall e e' r a.
(e -> e') -> NixSerializer r e a -> NixSerializer r e' a
mapErrorS
          HandshakeSError -> RemoteStoreError
RemoteStoreError_SerializerHandshake
          NixSerializer ProtoStoreConfig HandshakeSError WorkerMagic
forall r. NixSerializer r HandshakeSError WorkerMagic
workerMagic
        )
        WorkerMagic
WorkerMagic_Two

      NixSerializer ProtoStoreConfig RemoteStoreError ProtoVersion
-> ProtoVersion -> RemoteStoreT m ()
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m) =>
NixSerializer ProtoStoreConfig e a -> a -> m ()
sockPutS NixSerializer ProtoStoreConfig RemoteStoreError ProtoVersion
forall r e. NixSerializer r e ProtoVersion
protoVersion ProtoVersion
serverHandshakeInputOurVersion

      ProtoVersion
clientVersion <- NixSerializer ProtoStoreConfig RemoteStoreError ProtoVersion
-> RemoteStoreT m ProtoVersion
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m, Show a, Show e) =>
NixSerializer ProtoStoreConfig e a -> m a
sockGetS NixSerializer ProtoStoreConfig RemoteStoreError ProtoVersion
forall r e. NixSerializer r e ProtoVersion
protoVersion

      let leastCommonVersion :: ProtoVersion
leastCommonVersion = ProtoVersion -> ProtoVersion -> ProtoVersion
forall a. Ord a => a -> a -> a
min ProtoVersion
clientVersion ProtoVersion
serverHandshakeInputOurVersion

      Bool -> RemoteStoreT m () -> RemoteStoreT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtoVersion
clientVersion ProtoVersion -> ProtoVersion -> Bool
forall a. Ord a => a -> a -> Bool
< Word16 -> Word8 -> ProtoVersion
ProtoVersion Word16
1 Word8
10)
        (RemoteStoreT m () -> RemoteStoreT m ())
-> RemoteStoreT m () -> RemoteStoreT m ()
forall a b. (a -> b) -> a -> b
$ RemoteStoreError -> RemoteStoreT m ()
forall a. RemoteStoreError -> RemoteStoreT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        (RemoteStoreError -> RemoteStoreT m ())
-> RemoteStoreError -> RemoteStoreT m ()
forall a b. (a -> b) -> a -> b
$ WorkerException -> RemoteStoreError
RemoteStoreError_WorkerException
            WorkerException
WorkerException_ClientVersionTooOld

      Bool -> RemoteStoreT m () -> RemoteStoreT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtoVersion
clientVersion ProtoVersion -> ProtoVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Word16 -> Word8 -> ProtoVersion
ProtoVersion Word16
1 Word8
14) (RemoteStoreT m () -> RemoteStoreT m ())
-> RemoteStoreT m () -> RemoteStoreT m ()
forall a b. (a -> b) -> a -> b
$ do
        Word32
x :: Word32 <- NixSerializer ProtoStoreConfig RemoteStoreError Word32
-> RemoteStoreT m Word32
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m, Show a, Show e) =>
NixSerializer ProtoStoreConfig e a -> m a
sockGetS NixSerializer ProtoStoreConfig RemoteStoreError Word32
forall a r e. Integral a => NixSerializer r e a
int
        Bool -> RemoteStoreT m () -> RemoteStoreT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
x Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0) (RemoteStoreT m () -> RemoteStoreT m ())
-> RemoteStoreT m () -> RemoteStoreT m ()
forall a b. (a -> b) -> a -> b
$ do
          -- Obsolete CPU affinity.
          Word32
_ :: Word32 <- NixSerializer ProtoStoreConfig RemoteStoreError Word32
-> RemoteStoreT m Word32
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m, Show a, Show e) =>
NixSerializer ProtoStoreConfig e a -> m a
sockGetS NixSerializer ProtoStoreConfig RemoteStoreError Word32
forall a r e. Integral a => NixSerializer r e a
int
          () -> RemoteStoreT m ()
forall a. a -> RemoteStoreT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      Bool -> RemoteStoreT m () -> RemoteStoreT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtoVersion
clientVersion ProtoVersion -> ProtoVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Word16 -> Word8 -> ProtoVersion
ProtoVersion Word16
1 Word8
11) (RemoteStoreT m () -> RemoteStoreT m ())
-> RemoteStoreT m () -> RemoteStoreT m ()
forall a b. (a -> b) -> a -> b
$ do
        Word32
_ :: Word32 <- NixSerializer ProtoStoreConfig RemoteStoreError Word32
-> RemoteStoreT m Word32
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m, Show a, Show e) =>
NixSerializer ProtoStoreConfig e a -> m a
sockGetS NixSerializer ProtoStoreConfig RemoteStoreError Word32
forall a r e. Integral a => NixSerializer r e a
int -- obsolete reserveSpace
        () -> RemoteStoreT m ()
forall a. a -> RemoteStoreT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      Bool -> RemoteStoreT m () -> RemoteStoreT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtoVersion
clientVersion ProtoVersion -> ProtoVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Word16 -> Word8 -> ProtoVersion
ProtoVersion Word16
1 Word8
33) (RemoteStoreT m () -> RemoteStoreT m ())
-> RemoteStoreT m () -> RemoteStoreT m ()
forall a b. (a -> b) -> a -> b
$ do
        NixSerializer ProtoStoreConfig RemoteStoreError Text
-> Text -> RemoteStoreT m ()
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m) =>
NixSerializer ProtoStoreConfig e a -> a -> m ()
sockPutS
          ((SError -> RemoteStoreError)
-> NixSerializer ProtoStoreConfig SError Text
-> NixSerializer ProtoStoreConfig RemoteStoreError Text
forall e e' r a.
(e -> e') -> NixSerializer r e a -> NixSerializer r e' a
mapErrorS
             SError -> RemoteStoreError
RemoteStoreError_SerializerPut
             NixSerializer ProtoStoreConfig SError Text
forall r. NixSerializer r SError Text
text
          )
          Text
serverHandshakeInputNixVersion

      Bool -> RemoteStoreT m () -> RemoteStoreT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtoVersion
clientVersion ProtoVersion -> ProtoVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Word16 -> Word8 -> ProtoVersion
ProtoVersion Word16
1 Word8
35) (RemoteStoreT m () -> RemoteStoreT m ())
-> RemoteStoreT m () -> RemoteStoreT m ()
forall a b. (a -> b) -> a -> b
$ do
        NixSerializer ProtoStoreConfig RemoteStoreError (Maybe TrustedFlag)
-> Maybe TrustedFlag -> RemoteStoreT m ()
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m) =>
NixSerializer ProtoStoreConfig e a -> a -> m ()
sockPutS
          ((HandshakeSError -> RemoteStoreError)
-> NixSerializer
     ProtoStoreConfig HandshakeSError (Maybe TrustedFlag)
-> NixSerializer
     ProtoStoreConfig RemoteStoreError (Maybe TrustedFlag)
forall e e' r a.
(e -> e') -> NixSerializer r e a -> NixSerializer r e' a
mapErrorS
             HandshakeSError -> RemoteStoreError
RemoteStoreError_SerializerHandshake
             NixSerializer ProtoStoreConfig HandshakeSError (Maybe TrustedFlag)
forall r. NixSerializer r HandshakeSError (Maybe TrustedFlag)
trustedFlag
          )
          Maybe TrustedFlag
serverHandshakeInputTrust

      ServerHandshakeOutput -> RemoteStoreT m ServerHandshakeOutput
forall a. a -> RemoteStoreT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerHandshakeOutput
        { serverHandshakeOutputLeastCommonVersion :: ProtoVersion
serverHandshakeOutputLeastCommonVersion = ProtoVersion
leastCommonVersion
        , serverHandshakeOutputClientVersion :: ProtoVersion
serverHandshakeOutputClientVersion = ProtoVersion
clientVersion
        }

{-# WARNING _unimplemented "not yet implemented" #-}
_unimplemented :: RemoteStoreError
_unimplemented :: RemoteStoreError
_unimplemented = WorkerException -> RemoteStoreError
RemoteStoreError_WorkerException (WorkerException -> RemoteStoreError)
-> WorkerException -> RemoteStoreError
forall a b. (a -> b) -> a -> b
$ WorkerError -> WorkerException
WorkerException_Error (WorkerError -> WorkerException) -> WorkerError -> WorkerException
forall a b. (a -> b) -> a -> b
$ WorkerError
WorkerError_NotYetImplemented

bracketLogger
  :: MonadRemoteStore m
  => TunnelLogger
  -> m a
  -> m a
bracketLogger :: forall (m :: * -> *) a.
MonadRemoteStore m =>
TunnelLogger -> m a -> m a
bracketLogger TunnelLogger
tunnelLogger m a
m = do
  TunnelLogger -> m ()
forall (m :: * -> *). MonadRemoteStore m => TunnelLogger -> m ()
startWork TunnelLogger
tunnelLogger
  a
a <- m a
m
  TunnelLogger -> m ()
forall (m :: * -> *). MonadRemoteStore m => TunnelLogger -> m ()
stopWork TunnelLogger
tunnelLogger
  a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

---

data TunnelLogger = TunnelLogger
  { TunnelLogger -> IORef TunnelLoggerState
_tunnelLogger_state :: IORef TunnelLoggerState
  }

data TunnelLoggerState = TunnelLoggerState
  { TunnelLoggerState -> Bool
_tunnelLoggerState_canSendStderr :: Bool
  , TunnelLoggerState -> [Logger]
_tunnelLoggerState_pendingMsgs :: [Logger]
  }

newTunnelLogger :: IO TunnelLogger
newTunnelLogger :: IO TunnelLogger
newTunnelLogger = IORef TunnelLoggerState -> TunnelLogger
TunnelLogger (IORef TunnelLoggerState -> TunnelLogger)
-> IO (IORef TunnelLoggerState) -> IO TunnelLogger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TunnelLoggerState -> IO (IORef TunnelLoggerState)
forall a. a -> IO (IORef a)
newIORef (Bool -> [Logger] -> TunnelLoggerState
TunnelLoggerState Bool
False [])

enqueueMsg
  :: ( MonadRemoteStore m
     , MonadError LoggerSError m
     )
  => TunnelLogger
  -> Logger
  -> m ()
enqueueMsg :: forall (m :: * -> *).
(MonadRemoteStore m, MonadError LoggerSError m) =>
TunnelLogger -> Logger -> m ()
enqueueMsg TunnelLogger
x Logger
l = TunnelLogger
-> (TunnelLoggerState -> (TunnelLoggerState, m ())) -> m ()
forall (m :: * -> *) a.
MonadRemoteStore m =>
TunnelLogger
-> (TunnelLoggerState -> (TunnelLoggerState, m a)) -> m a
updateLogger TunnelLogger
x ((TunnelLoggerState -> (TunnelLoggerState, m ())) -> m ())
-> (TunnelLoggerState -> (TunnelLoggerState, m ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \st :: TunnelLoggerState
st@(TunnelLoggerState Bool
c [Logger]
p) -> case Bool
c of
  Bool
True -> (TunnelLoggerState
st, NixSerializer ProtoStoreConfig LoggerSError Logger
-> Logger -> m ()
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m) =>
NixSerializer ProtoStoreConfig e a -> a -> m ()
sockPutS NixSerializer ProtoStoreConfig LoggerSError Logger
forall r. HasProtoVersion r => NixSerializer r LoggerSError Logger
logger Logger
l)
  Bool
False -> (Bool -> [Logger] -> TunnelLoggerState
TunnelLoggerState Bool
c (Logger
lLogger -> [Logger] -> [Logger]
forall a. a -> [a] -> [a]
:[Logger]
p), () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

_log
  :: ( MonadRemoteStore m
     , MonadError LoggerSError m
     )
  => TunnelLogger
  -> Text
  -> m ()
_log :: forall (m :: * -> *).
(MonadRemoteStore m, MonadError LoggerSError m) =>
TunnelLogger -> Text -> m ()
_log TunnelLogger
l Text
s = TunnelLogger -> Logger -> m ()
forall (m :: * -> *).
(MonadRemoteStore m, MonadError LoggerSError m) =>
TunnelLogger -> Logger -> m ()
enqueueMsg TunnelLogger
l (Text -> Logger
Logger_Next Text
s)

startWork
  :: MonadRemoteStore m
  => TunnelLogger
  -> m ()
startWork :: forall (m :: * -> *). MonadRemoteStore m => TunnelLogger -> m ()
startWork TunnelLogger
x = TunnelLogger
-> (TunnelLoggerState -> (TunnelLoggerState, m ())) -> m ()
forall (m :: * -> *) a.
MonadRemoteStore m =>
TunnelLogger
-> (TunnelLoggerState -> (TunnelLoggerState, m a)) -> m a
updateLogger TunnelLogger
x ((TunnelLoggerState -> (TunnelLoggerState, m ())) -> m ())
-> (TunnelLoggerState -> (TunnelLoggerState, m ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \(TunnelLoggerState Bool
_ [Logger]
p) -> (,)
  (Bool -> [Logger] -> TunnelLoggerState
TunnelLoggerState Bool
True []) (m () -> (TunnelLoggerState, m ()))
-> m () -> (TunnelLoggerState, m ())
forall a b. (a -> b) -> a -> b
$
  ((Logger -> m ()) -> [Logger] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (NixSerializer ProtoStoreConfig RemoteStoreError Logger
-> Logger -> m ()
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m) =>
NixSerializer ProtoStoreConfig e a -> a -> m ()
sockPutS NixSerializer ProtoStoreConfig RemoteStoreError Logger
logger') ([Logger] -> m ()) -> [Logger] -> m ()
forall a b. (a -> b) -> a -> b
$ [Logger] -> [Logger]
forall a. [a] -> [a]
reverse [Logger]
p)
  where logger' :: NixSerializer ProtoStoreConfig RemoteStoreError Logger
logger' = (LoggerSError -> RemoteStoreError)
-> NixSerializer ProtoStoreConfig LoggerSError Logger
-> NixSerializer ProtoStoreConfig RemoteStoreError Logger
forall e e' r a.
(e -> e') -> NixSerializer r e a -> NixSerializer r e' a
mapErrorS LoggerSError -> RemoteStoreError
RemoteStoreError_SerializerLogger NixSerializer ProtoStoreConfig LoggerSError Logger
forall r. HasProtoVersion r => NixSerializer r LoggerSError Logger
logger

stopWork
  :: MonadRemoteStore m
  => TunnelLogger
  -> m ()
stopWork :: forall (m :: * -> *). MonadRemoteStore m => TunnelLogger -> m ()
stopWork TunnelLogger
x = TunnelLogger
-> (TunnelLoggerState -> (TunnelLoggerState, m ())) -> m ()
forall (m :: * -> *) a.
MonadRemoteStore m =>
TunnelLogger
-> (TunnelLoggerState -> (TunnelLoggerState, m a)) -> m a
updateLogger TunnelLogger
x ((TunnelLoggerState -> (TunnelLoggerState, m ())) -> m ())
-> (TunnelLoggerState -> (TunnelLoggerState, m ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \TunnelLoggerState
_ -> (,)
  (Bool -> [Logger] -> TunnelLoggerState
TunnelLoggerState Bool
False [])
  (NixSerializer ProtoStoreConfig RemoteStoreError Logger
-> Logger -> m ()
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m) =>
NixSerializer ProtoStoreConfig e a -> a -> m ()
sockPutS ((LoggerSError -> RemoteStoreError)
-> NixSerializer ProtoStoreConfig LoggerSError Logger
-> NixSerializer ProtoStoreConfig RemoteStoreError Logger
forall e e' r a.
(e -> e') -> NixSerializer r e a -> NixSerializer r e' a
mapErrorS LoggerSError -> RemoteStoreError
RemoteStoreError_SerializerLogger NixSerializer ProtoStoreConfig LoggerSError Logger
forall r. HasProtoVersion r => NixSerializer r LoggerSError Logger
logger) Logger
Logger_Last)

-- | Stop sending logging and report an error.
--
-- Returns true if the the session was in a state that allowed the error to be
-- sent.
--
-- Unlike 'stopWork', this function may be called at any time to (try) to end a
-- session with an error.
_stopWorkOnError
  :: MonadRemoteStore m
  => TunnelLogger
  -> ErrorInfo
  -> m Bool
_stopWorkOnError :: forall (m :: * -> *).
MonadRemoteStore m =>
TunnelLogger -> ErrorInfo -> m Bool
_stopWorkOnError TunnelLogger
x ErrorInfo
ex = TunnelLogger
-> (TunnelLoggerState -> (TunnelLoggerState, m Bool)) -> m Bool
forall (m :: * -> *) a.
MonadRemoteStore m =>
TunnelLogger
-> (TunnelLoggerState -> (TunnelLoggerState, m a)) -> m a
updateLogger TunnelLogger
x ((TunnelLoggerState -> (TunnelLoggerState, m Bool)) -> m Bool)
-> (TunnelLoggerState -> (TunnelLoggerState, m Bool)) -> m Bool
forall a b. (a -> b) -> a -> b
$ \TunnelLoggerState
st ->
  case TunnelLoggerState -> Bool
_tunnelLoggerState_canSendStderr TunnelLoggerState
st of
    Bool
False -> (TunnelLoggerState
st, Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
    Bool
True -> (,) (Bool -> [Logger] -> TunnelLoggerState
TunnelLoggerState Bool
False []) (m Bool -> (TunnelLoggerState, m Bool))
-> m Bool -> (TunnelLoggerState, m Bool)
forall a b. (a -> b) -> a -> b
$ do
      m ProtoVersion
forall (m :: * -> *). MonadRemoteStore m => m ProtoVersion
getProtoVersion m ProtoVersion -> (ProtoVersion -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ProtoVersion
pv -> if ProtoVersion -> Word8
protoVersion_minor ProtoVersion
pv Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
26
        then NixSerializer ProtoStoreConfig RemoteStoreError Logger
-> Logger -> m ()
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m) =>
NixSerializer ProtoStoreConfig e a -> a -> m ()
sockPutS NixSerializer ProtoStoreConfig RemoteStoreError Logger
logger' (Either BasicError ErrorInfo -> Logger
Logger_Error (ErrorInfo -> Either BasicError ErrorInfo
forall a b. b -> Either a b
Right ErrorInfo
ex))
        else NixSerializer ProtoStoreConfig RemoteStoreError Logger
-> Logger -> m ()
forall (m :: * -> *) e a.
(MonadRemoteStore m, MonadError e m) =>
NixSerializer ProtoStoreConfig e a -> a -> m ()
sockPutS NixSerializer ProtoStoreConfig RemoteStoreError Logger
logger' (Either BasicError ErrorInfo -> Logger
Logger_Error (BasicError -> Either BasicError ErrorInfo
forall a b. a -> Either a b
Left (Int -> Text -> BasicError
BasicError Int
0 (String -> Text
Data.Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ErrorInfo -> String
forall a. Show a => a -> String
show ErrorInfo
ex))))
      Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  where logger' :: NixSerializer ProtoStoreConfig RemoteStoreError Logger
logger' = (LoggerSError -> RemoteStoreError)
-> NixSerializer ProtoStoreConfig LoggerSError Logger
-> NixSerializer ProtoStoreConfig RemoteStoreError Logger
forall e e' r a.
(e -> e') -> NixSerializer r e a -> NixSerializer r e' a
mapErrorS LoggerSError -> RemoteStoreError
RemoteStoreError_SerializerLogger NixSerializer ProtoStoreConfig LoggerSError Logger
forall r. HasProtoVersion r => NixSerializer r LoggerSError Logger
logger

updateLogger
  :: MonadRemoteStore m
  => TunnelLogger
  -> (TunnelLoggerState -> (TunnelLoggerState, m a))
  -> m a
updateLogger :: forall (m :: * -> *) a.
MonadRemoteStore m =>
TunnelLogger
-> (TunnelLoggerState -> (TunnelLoggerState, m a)) -> m a
updateLogger TunnelLogger
x = m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m a) -> m a)
-> ((TunnelLoggerState -> (TunnelLoggerState, m a)) -> m (m a))
-> (TunnelLoggerState -> (TunnelLoggerState, m a))
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (m a) -> m (m a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (m a) -> m (m a))
-> ((TunnelLoggerState -> (TunnelLoggerState, m a)) -> IO (m a))
-> (TunnelLoggerState -> (TunnelLoggerState, m a))
-> m (m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef TunnelLoggerState
-> (TunnelLoggerState -> (TunnelLoggerState, m a)) -> IO (m a)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (TunnelLogger -> IORef TunnelLoggerState
_tunnelLogger_state TunnelLogger
x)