From 960407b0a1e88cfd6a3f07f4bfc9e5e2654d72a4 Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 9 Dec 2023 18:36:49 +0100 Subject: [PATCH] remote: add StoreConnection, reclaim runStoreSocket, now greetServer --- hnix-store-remote/hnix-store-remote.cabal | 2 +- .../src/System/Nix/Store/Remote.hs | 154 +++++++++++------- .../System/Nix/Store/Remote/Client/Core.hs | 127 +++++++-------- .../src/System/Nix/Store/Remote/Server.hs | 18 +- .../Nix/Store/Remote/Types/StoreConfig.hs | 29 +++- hnix-store-remote/tests-io/NixDaemonSpec.hs | 2 +- 6 files changed, 188 insertions(+), 144 deletions(-) diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 1dd8116..831b820 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -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 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index 6c1fe7d..6b38841 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -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) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs index 055220b..e16da08 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs @@ -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 + } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs index b8a30af..94c0036 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs @@ -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 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs index b590643..86e71b4 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs @@ -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 diff --git a/hnix-store-remote/tests-io/NixDaemonSpec.hs b/hnix-store-remote/tests-io/NixDaemonSpec.hs index 2616c2f..3d56e65 100644 --- a/hnix-store-remote/tests-io/NixDaemonSpec.hs +++ b/hnix-store-remote/tests-io/NixDaemonSpec.hs @@ -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") >> )