mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-08-17 13:51:21 +03:00
remote: add StoreConnection, reclaim runStoreSocket, now greetServer
This commit is contained in:
parent
1f1d437a40
commit
960407b0a1
@ -114,7 +114,7 @@ library
|
||||
, data-default-class
|
||||
, dependent-sum > 0.7
|
||||
, dependent-sum-template >= 0.2.0.1 && < 0.3
|
||||
, directory
|
||||
-- , directory
|
||||
, dlist >= 1.0
|
||||
, exceptions
|
||||
, generic-arbitrary < 1.1
|
||||
|
@ -10,11 +10,11 @@ module System.Nix.Store.Remote
|
||||
, MonadStore
|
||||
-- * Runners
|
||||
, runStore
|
||||
, runStoreOpts
|
||||
, runStoreOptsTCP
|
||||
, runStoreConnection
|
||||
, runStoreSocket
|
||||
-- ** Daemon
|
||||
, runDaemon
|
||||
, runDaemonOpts
|
||||
, runDaemonConnection
|
||||
, justdoit
|
||||
) where
|
||||
|
||||
@ -30,15 +30,16 @@ import System.Nix.Store.Remote.MonadStore
|
||||
, RemoteStoreT
|
||||
, RemoteStoreError(RemoteStoreError_GetAddrInfoFailed))
|
||||
import System.Nix.Store.Remote.Client
|
||||
import System.Nix.Store.Remote.Server (WorkerHelper, runProxyDaemon)
|
||||
import System.Nix.Store.Remote.Types
|
||||
|
||||
import qualified Control.Monad.Catch
|
||||
import qualified Network.Socket
|
||||
import qualified System.Directory
|
||||
-- see TODO bellow
|
||||
--import qualified System.Directory
|
||||
|
||||
-- wip daemon
|
||||
-- wip justdoit
|
||||
import System.Nix.StorePath (StorePath)
|
||||
import System.Nix.Store.Remote.Server (WorkerHelper, runDaemonSocket)
|
||||
import qualified System.Nix.StorePath
|
||||
|
||||
-- * Compat
|
||||
@ -53,45 +54,22 @@ runStore
|
||||
)
|
||||
=> RemoteStoreT m a
|
||||
-> Run m a
|
||||
runStore = runStoreOpts defaultSockPath
|
||||
runStore = runStoreConnection def
|
||||
|
||||
defaultSockPath :: String
|
||||
defaultSockPath = "/nix/var/nix/daemon-socket/socket"
|
||||
|
||||
runStoreOpts
|
||||
runStoreConnection
|
||||
:: ( MonadIO m
|
||||
, MonadMask m
|
||||
)
|
||||
=> FilePath
|
||||
=> StoreConnection
|
||||
-> RemoteStoreT m a
|
||||
-> Run m a
|
||||
runStoreOpts socketPath =
|
||||
runStoreOpts'
|
||||
Network.Socket.AF_UNIX
|
||||
(SockAddrUnix socketPath)
|
||||
runStoreConnection sc k =
|
||||
connectionToSocket sc
|
||||
>>= \case
|
||||
Left e -> pure (Left e, mempty)
|
||||
Right (fam, sock) -> runStoreSocket fam sock k
|
||||
|
||||
runStoreOptsTCP
|
||||
:: ( MonadIO m
|
||||
, MonadMask m
|
||||
)
|
||||
=> String
|
||||
-> Int
|
||||
-> RemoteStoreT m a
|
||||
-> Run m a
|
||||
runStoreOptsTCP host port code = do
|
||||
addrInfo <- liftIO $ Network.Socket.getAddrInfo
|
||||
(Just Network.Socket.defaultHints)
|
||||
(Just host)
|
||||
(Just $ show port)
|
||||
case addrInfo of
|
||||
(sockAddr:_) ->
|
||||
runStoreOpts'
|
||||
(Network.Socket.addrFamily sockAddr)
|
||||
(Network.Socket.addrAddress sockAddr)
|
||||
code
|
||||
_ -> pure (Left RemoteStoreError_GetAddrInfoFailed, mempty)
|
||||
|
||||
runStoreOpts'
|
||||
runStoreSocket
|
||||
:: ( MonadIO m
|
||||
, MonadMask m
|
||||
)
|
||||
@ -99,21 +77,25 @@ runStoreOpts'
|
||||
-> SockAddr
|
||||
-> RemoteStoreT m a
|
||||
-> Run m a
|
||||
runStoreOpts' sockFamily sockAddr code =
|
||||
runStoreSocket sockFamily sockAddr code =
|
||||
Control.Monad.Catch.bracket
|
||||
(liftIO open)
|
||||
(liftIO . Network.Socket.close . hasStoreSocket)
|
||||
(\s -> runRemoteStoreT s $ runStoreSocket code)
|
||||
(\s -> runRemoteStoreT s $ greetServer >> code)
|
||||
where
|
||||
open = do
|
||||
soc <- Network.Socket.socket sockFamily Network.Socket.Stream 0
|
||||
soc <-
|
||||
Network.Socket.socket
|
||||
sockFamily
|
||||
Network.Socket.Stream
|
||||
Network.Socket.defaultProtocol
|
||||
Network.Socket.connect soc sockAddr
|
||||
pure soc
|
||||
|
||||
justdoit :: Run IO (Bool, Bool)
|
||||
justdoit = do
|
||||
runDaemonOpts handler "/tmp/dsock" $
|
||||
runStoreOpts "/tmp/dsock"
|
||||
runDaemonConnection handler (StoreConnection_Socket "/tmp/dsock") $
|
||||
runStoreConnection (StoreConnection_Socket "/tmp/dsock")
|
||||
$ do
|
||||
a <- isValidPath pth
|
||||
b <- isValidPath pth
|
||||
@ -140,31 +122,81 @@ runDaemon
|
||||
-> m a
|
||||
-> m a
|
||||
runDaemon workerHelper =
|
||||
runDaemonOpts
|
||||
runDaemonConnection
|
||||
workerHelper
|
||||
defaultSockPath
|
||||
def
|
||||
|
||||
-- | Run an emulated nix daemon on given socket address.
|
||||
-- | Run an emulated nix daemon using given @StoreConnection@
|
||||
-- the deamon will close when the continuation returns.
|
||||
runDaemonOpts
|
||||
runDaemonConnection
|
||||
:: forall m a
|
||||
. ( MonadIO m
|
||||
, MonadConc m
|
||||
)
|
||||
=> WorkerHelper m
|
||||
-> FilePath
|
||||
-> StoreConnection
|
||||
-> m a
|
||||
-> m a
|
||||
runDaemonOpts workerHelper f k = Control.Monad.Catch.bracket
|
||||
(liftIO
|
||||
$ Network.Socket.socket
|
||||
Network.Socket.AF_UNIX
|
||||
Network.Socket.Stream
|
||||
Network.Socket.defaultProtocol
|
||||
)
|
||||
(\lsock -> liftIO $ Network.Socket.close lsock *> System.Directory.removeFile f)
|
||||
$ \lsock -> do
|
||||
-- ^^^^^^^^^^^^
|
||||
-- TODO: this: --------------------------------------------------////////////
|
||||
liftIO $ Network.Socket.bind lsock (SockAddrUnix f)
|
||||
runDaemonSocket workerHelper lsock k
|
||||
runDaemonConnection workerHelper sc k =
|
||||
connectionToSocket sc
|
||||
>>= \case
|
||||
Left e -> error $ show e
|
||||
Right (fam, sock) -> runDaemonSocket workerHelper fam sock k
|
||||
|
||||
-- | Run an emulated nix daemon using given @StoreConnection@
|
||||
-- the deamon will close when the continuation returns.
|
||||
runDaemonSocket
|
||||
:: forall m a
|
||||
. ( MonadIO m
|
||||
, MonadConc m
|
||||
)
|
||||
=> WorkerHelper m
|
||||
-> Family
|
||||
-> SockAddr
|
||||
-> m a
|
||||
-> m a
|
||||
runDaemonSocket workerHelper sockFamily sockAddr k =
|
||||
Control.Monad.Catch.bracket
|
||||
(liftIO
|
||||
$ Network.Socket.socket
|
||||
sockFamily
|
||||
Network.Socket.Stream
|
||||
Network.Socket.defaultProtocol
|
||||
)
|
||||
(\lsock -> liftIO $ Network.Socket.close lsock) -- *> System.Directory.removeFile f)
|
||||
$ \lsock -> do
|
||||
-- ^^^^^^^^^^^^
|
||||
-- TODO: this: -------------------------------------------------------////////////
|
||||
-- should really be
|
||||
-- a file lock followed by unlink *before* bind rather than after close. If
|
||||
-- the program crashes (or loses power or something) then a stale unix
|
||||
-- socket will stick around and prevent the daemon from starting. using a
|
||||
-- lock file instead means only one "copy" of the daemon can hold the lock,
|
||||
-- and can safely unlink the socket before binding no matter how shutdown
|
||||
-- occured.
|
||||
|
||||
-- set up the listening socket
|
||||
liftIO $ Network.Socket.bind lsock sockAddr
|
||||
runProxyDaemon workerHelper lsock k
|
||||
|
||||
connectionToSocket
|
||||
:: MonadIO m
|
||||
=> StoreConnection
|
||||
-> m (Either RemoteStoreError (Family, SockAddr))
|
||||
connectionToSocket (StoreConnection_Socket (StoreSocketPath f)) =
|
||||
pure $ pure
|
||||
( Network.Socket.AF_UNIX
|
||||
, SockAddrUnix f
|
||||
)
|
||||
connectionToSocket (StoreConnection_TCP StoreTCP{..}) = do
|
||||
addrInfo <- liftIO $ Network.Socket.getAddrInfo
|
||||
(Just Network.Socket.defaultHints)
|
||||
(Just storeTCPHost)
|
||||
(Just $ show storeTCPPort)
|
||||
case addrInfo of
|
||||
(sockAddr:_) ->
|
||||
pure $ pure
|
||||
( Network.Socket.addrFamily sockAddr
|
||||
, Network.Socket.addrAddress sockAddr
|
||||
)
|
||||
_ -> pure (Left RemoteStoreError_GetAddrInfoFailed)
|
||||
|
@ -1,6 +1,6 @@
|
||||
module System.Nix.Store.Remote.Client.Core
|
||||
( Run
|
||||
, runStoreSocket
|
||||
, greetServer
|
||||
, doReq
|
||||
) where
|
||||
|
||||
@ -78,81 +78,68 @@ doReq = \case
|
||||
$ getReplyS @a
|
||||
)
|
||||
|
||||
runStoreSocket
|
||||
greetServer
|
||||
:: MonadRemoteStore m
|
||||
=> m a
|
||||
-> m a
|
||||
runStoreSocket code = do
|
||||
ClientHandshakeOutput{..}
|
||||
<- greet
|
||||
=> m ClientHandshakeOutput
|
||||
greetServer = do
|
||||
sockPutS
|
||||
(mapErrorS
|
||||
RemoteStoreError_SerializerHandshake
|
||||
workerMagic
|
||||
)
|
||||
WorkerMagic_One
|
||||
|
||||
setProtoVersion clientHandshakeOutputLeastCommonVersion
|
||||
code
|
||||
magic <-
|
||||
sockGetS
|
||||
$ mapErrorS
|
||||
RemoteStoreError_SerializerHandshake
|
||||
workerMagic
|
||||
|
||||
where
|
||||
greet
|
||||
:: MonadRemoteStore m
|
||||
=> m ClientHandshakeOutput
|
||||
greet = do
|
||||
unless
|
||||
(magic == WorkerMagic_Two)
|
||||
$ throwError RemoteStoreError_WorkerMagic2Mismatch
|
||||
|
||||
sockPutS
|
||||
(mapErrorS
|
||||
RemoteStoreError_SerializerHandshake
|
||||
workerMagic
|
||||
)
|
||||
WorkerMagic_One
|
||||
daemonVersion <- sockGetS protoVersion
|
||||
|
||||
magic <-
|
||||
when (daemonVersion < ProtoVersion 1 10)
|
||||
$ throwError RemoteStoreError_ClientVersionTooOld
|
||||
|
||||
pv <- getProtoVersion
|
||||
sockPutS protoVersion pv
|
||||
|
||||
let leastCommonVersion = min daemonVersion pv
|
||||
|
||||
when (leastCommonVersion >= ProtoVersion 1 14)
|
||||
$ sockPutS int (0 :: Int) -- affinity, obsolete
|
||||
|
||||
when (leastCommonVersion >= ProtoVersion 1 11) $ do
|
||||
sockPutS
|
||||
(mapErrorS RemoteStoreError_SerializerPut bool)
|
||||
False -- reserveSpace, obsolete
|
||||
|
||||
daemonNixVersion <- if leastCommonVersion >= ProtoVersion 1 33
|
||||
then do
|
||||
-- If we were buffering I/O, we would flush the output here.
|
||||
txtVer <-
|
||||
sockGetS
|
||||
$ mapErrorS
|
||||
RemoteStoreError_SerializerHandshake
|
||||
workerMagic
|
||||
$ mapErrorS
|
||||
RemoteStoreError_SerializerGet
|
||||
text
|
||||
pure $ Just txtVer
|
||||
else pure Nothing
|
||||
|
||||
unless
|
||||
(magic == WorkerMagic_Two)
|
||||
$ throwError RemoteStoreError_WorkerMagic2Mismatch
|
||||
remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35
|
||||
then do
|
||||
sockGetS
|
||||
$ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag
|
||||
else pure Nothing
|
||||
|
||||
daemonVersion <- sockGetS protoVersion
|
||||
setProtoVersion leastCommonVersion
|
||||
processOutput
|
||||
|
||||
when (daemonVersion < ProtoVersion 1 10)
|
||||
$ throwError RemoteStoreError_ClientVersionTooOld
|
||||
|
||||
pv <- getProtoVersion
|
||||
sockPutS protoVersion pv
|
||||
|
||||
let leastCommonVersion = min daemonVersion pv
|
||||
|
||||
when (leastCommonVersion >= ProtoVersion 1 14)
|
||||
$ sockPutS int (0 :: Int) -- affinity, obsolete
|
||||
|
||||
when (leastCommonVersion >= ProtoVersion 1 11) $ do
|
||||
sockPutS
|
||||
(mapErrorS RemoteStoreError_SerializerPut bool)
|
||||
False -- reserveSpace, obsolete
|
||||
|
||||
daemonNixVersion <- if leastCommonVersion >= ProtoVersion 1 33
|
||||
then do
|
||||
-- If we were buffering I/O, we would flush the output here.
|
||||
txtVer <-
|
||||
sockGetS
|
||||
$ mapErrorS
|
||||
RemoteStoreError_SerializerGet
|
||||
text
|
||||
pure $ Just txtVer
|
||||
else pure Nothing
|
||||
|
||||
remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35
|
||||
then do
|
||||
sockGetS
|
||||
$ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag
|
||||
else pure Nothing
|
||||
|
||||
setProtoVersion leastCommonVersion
|
||||
processOutput
|
||||
|
||||
pure ClientHandshakeOutput
|
||||
{ clientHandshakeOutputNixVersion = daemonNixVersion
|
||||
, clientHandshakeOutputTrust = remoteTrustsUs
|
||||
, clientHandshakeOutputLeastCommonVersion = leastCommonVersion
|
||||
, clientHandshakeOutputServerVersion = daemonVersion
|
||||
}
|
||||
pure ClientHandshakeOutput
|
||||
{ clientHandshakeOutputNixVersion = daemonNixVersion
|
||||
, clientHandshakeOutputTrust = remoteTrustsUs
|
||||
, clientHandshakeOutputLeastCommonVersion = leastCommonVersion
|
||||
, clientHandshakeOutputServerVersion = daemonVersion
|
||||
}
|
||||
|
@ -1,6 +1,10 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
module System.Nix.Store.Remote.Server where
|
||||
module System.Nix.Store.Remote.Server
|
||||
( runProxyDaemon
|
||||
, WorkerHelper
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.Classy.Async
|
||||
import Control.Monad (join, void, when)
|
||||
@ -41,7 +45,7 @@ type WorkerHelper m
|
||||
|
||||
-- | Run an emulated nix daemon on given socket address.
|
||||
-- The deamon will close when the continuation returns.
|
||||
runDaemonSocket
|
||||
runProxyDaemon
|
||||
:: forall m a
|
||||
. ( MonadIO m
|
||||
, MonadConc m
|
||||
@ -50,7 +54,7 @@ runDaemonSocket
|
||||
-> Socket
|
||||
-> m a
|
||||
-> m a
|
||||
runDaemonSocket workerHelper lsock k = do
|
||||
runProxyDaemon workerHelper lsock k = do
|
||||
liftIO $ listen lsock maxListenQueue
|
||||
|
||||
liftIO $ Data.Text.IO.putStrLn "listening"
|
||||
@ -259,14 +263,14 @@ enqueueMsg x l = updateLogger x $ \st@(TunnelLoggerState c p) -> case c of
|
||||
True -> (st, sockPutS logger l)
|
||||
False -> (TunnelLoggerState c (l:p), pure ())
|
||||
|
||||
log
|
||||
_log
|
||||
:: ( MonadRemoteStore m
|
||||
, MonadError LoggerSError m
|
||||
)
|
||||
=> TunnelLogger
|
||||
-> Text
|
||||
-> m ()
|
||||
log l s = enqueueMsg l (Logger_Next s)
|
||||
_log l s = enqueueMsg l (Logger_Next s)
|
||||
|
||||
startWork
|
||||
:: MonadRemoteStore m
|
||||
@ -292,12 +296,12 @@ stopWork x = updateLogger x $ \_ -> (,)
|
||||
--
|
||||
-- Unlike 'stopWork', this function may be called at any time to (try) to end a
|
||||
-- session with an error.
|
||||
stopWorkOnError
|
||||
_stopWorkOnError
|
||||
:: MonadRemoteStore m
|
||||
=> TunnelLogger
|
||||
-> ErrorInfo
|
||||
-> m Bool
|
||||
stopWorkOnError x ex = updateLogger x $ \st ->
|
||||
_stopWorkOnError x ex = updateLogger x $ \st ->
|
||||
case _tunnelLoggerState_canSendStderr st of
|
||||
False -> (st, pure False)
|
||||
True -> (,) (TunnelLoggerState False []) $ do
|
||||
|
@ -1,11 +1,15 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
module System.Nix.Store.Remote.Types.StoreConfig
|
||||
( ProtoStoreConfig(..)
|
||||
, StoreConfig(..)
|
||||
, StoreSocketPath(..)
|
||||
, StoreTCP(..)
|
||||
, StoreConnection(..)
|
||||
, HasStoreSocket(..)
|
||||
) where
|
||||
|
||||
import Data.Default.Class (Default(def))
|
||||
import Data.String (IsString)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.Socket (Socket)
|
||||
import System.Nix.StorePath (HasStoreDir(..), StoreDir)
|
||||
@ -34,7 +38,24 @@ instance HasStoreDir ProtoStoreConfig where
|
||||
instance HasProtoVersion ProtoStoreConfig where
|
||||
hasProtoVersion = protoStoreConfigProtoVersion
|
||||
|
||||
data StoreConfig = StoreConfig
|
||||
{ storeConfigDir :: Maybe StoreDir
|
||||
, storeConfigSocketPath :: FilePath
|
||||
newtype StoreSocketPath = StoreSocketPath
|
||||
{ unStoreSocketPath :: FilePath
|
||||
}
|
||||
deriving newtype (IsString)
|
||||
deriving stock (Eq, Generic, Ord, Show)
|
||||
|
||||
instance Default StoreSocketPath where
|
||||
def = StoreSocketPath "/nix/var/nix/daemon-socket/socket"
|
||||
|
||||
data StoreTCP = StoreTCP
|
||||
{ storeTCPHost :: String
|
||||
, storeTCPPort :: Int
|
||||
} deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
data StoreConnection
|
||||
= StoreConnection_Socket StoreSocketPath
|
||||
| StoreConnection_TCP StoreTCP
|
||||
deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
instance Default StoreConnection where
|
||||
def = StoreConnection_Socket def
|
||||
|
@ -115,7 +115,7 @@ startDaemon fp = do
|
||||
procHandle <- createProcessEnv fp "nix-daemon" []
|
||||
waitSocket sockFp 30
|
||||
pure ( procHandle
|
||||
, runStoreOpts sockFp
|
||||
, runStoreConnection (StoreConnection_Socket (StoreSocketPath sockFp))
|
||||
. (setStoreDir (StoreDir $ Data.ByteString.Char8.pack $ fp </> "store")
|
||||
>>
|
||||
)
|
||||
|
Loading…
Reference in New Issue
Block a user