From 2bdd171d224723a6cdc912939e5c3b211946d42a Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 8 Dec 2023 11:57:38 +0100 Subject: [PATCH] wip/remote: add daemon runners, simplify server using StoreReply --- hnix-store-remote/hnix-store-remote.cabal | 3 + .../src/System/Nix/Store/Remote.hs | 94 +++++++++++- .../src/System/Nix/Store/Remote/Server.hs | 135 +++++++----------- 3 files changed, 147 insertions(+), 85 deletions(-) diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 74a0869..9cee10a 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -114,13 +114,16 @@ library , data-default-class , dependent-sum > 0.7 , dependent-sum-template >= 0.2.0.1 && < 0.3 + , directory , dlist >= 1.0 + , exceptions , generic-arbitrary < 1.1 , hashable , text , time , transformers , network + , monad-control , mtl , QuickCheck , unordered-containers diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index cf4b23e..63560c3 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} + module System.Nix.Store.Remote - ( - module System.Nix.Store.Types + ( module System.Nix.Store.Types , module System.Nix.Store.Remote.Client , module System.Nix.Store.Remote.MonadStore , module System.Nix.Store.Remote.Types @@ -10,6 +12,10 @@ module System.Nix.Store.Remote , runStore , runStoreOpts , runStoreOptsTCP + -- ** Daemon + , runDaemon + , runDaemonOpts + , justdoit ) where import Data.Default.Class (Default(def)) @@ -23,6 +29,16 @@ import System.Nix.Store.Remote.Types import qualified Control.Exception import qualified Network.Socket +-- wip daemon +import Control.Monad.Conc.Class (MonadConc) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Control (MonadBaseControl) +import System.Nix.StorePath (StorePath) +import System.Nix.Store.Remote.Server (WorkerHelper, runDaemonSocket) +import qualified System.Directory +import qualified System.Nix.StorePath +import qualified Control.Monad.Catch + -- * Compat type MonadStore = RemoteStoreT StoreConfig IO @@ -31,9 +47,9 @@ type MonadStore = RemoteStoreT StoreConfig IO runStore :: MonadStore a -> Run IO a runStore = runStoreOpts defaultSockPath def - where - defaultSockPath :: String - defaultSockPath = "/nix/var/nix/daemon-socket/socket" + +defaultSockPath :: String +defaultSockPath = "/nix/var/nix/daemon-socket/socket" runStoreOpts :: FilePath @@ -84,3 +100,71 @@ runStoreOpts' sockFamily sockAddr storeRootDir code = { preStoreConfig_socket = soc , preStoreConfig_dir = storeRootDir } + +justdoit :: Run IO (Bool, Bool) +justdoit = do + runDaemonOpts def handler "/tmp/dsock" $ + runStoreOpts "/tmp/dsock" def + $ do + a <- isValidPath pth + b <- isValidPath pth + pure (a, b) + where + pth :: StorePath + pth = + either (error . show) id + $ System.Nix.StorePath.parsePathFromText + def + "/nix/store/yyznqbwam67cmp7zfwk0rkgmi9yqsdsm-hnix-store-core-0.8.0.0" + + handler :: MonadIO m => WorkerHelper m + handler k = do + x <- liftIO $ runStore $ doReq k + either (error . show) pure (fst x) + +runDaemon + :: forall m a + . ( MonadIO m + , MonadBaseControl IO m + , MonadConc m + ) + => WorkerHelper m + -> m a + -> m a +runDaemon workerHelper k = runDaemonOpts def workerHelper defaultSockPath k + +-- | Run an emulated nix daemon on given socket address. +-- the deamon will close when the continuation returns. +runDaemonOpts + :: forall m a + . ( MonadIO m + , MonadBaseControl IO m + , MonadConc m + ) + => StoreDir + -> WorkerHelper m + -> FilePath + -> m a + -> m a +runDaemonOpts sd 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: --------------------------------------------------//////////// + -- 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 (SockAddrUnix f) + runDaemonSocket sd workerHelper lsock k 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 41cd473..54e1aa8 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs @@ -22,16 +22,25 @@ import System.Nix.StorePath (StoreDir) import System.Nix.Store.Remote.Serializer as RB 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.StoreConfig (HasStoreSocket(..), StoreConfig(..), PreStoreConfig(..), preStoreConfigToStoreConfig) import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..)) import System.Nix.Store.Remote.Types.Logger (BasicError(..), ErrorInfo, Logger(..)) - import System.Nix.Store.Remote.MonadStore (WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT, mapStoreConfig) import System.Nix.Store.Remote.Types.Handshake (ServerHandshakeInput(..), ServerHandshakeOutput(..)) import System.Nix.Store.Remote.Types.ProtoVersion (ourProtoVersion) import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) -type WorkerHelper m = forall a. StoreRequest a -> m a +-- wip +-- import Data.Some (traverseSome) +import Data.Functor.Identity + +type WorkerHelper m + = forall a + . ( Show a + , StoreReply a + ) + => StoreRequest a -> m a -- | Run an emulated nix daemon on given socket address. -- The deamon will close when the continuation returns. @@ -39,8 +48,6 @@ runDaemonSocket :: forall m a . ( MonadIO m , MonadConc m - , MonadError RemoteStoreError m - , MonadReader StoreConfig m ) => StoreDir -> WorkerHelper m @@ -63,7 +70,9 @@ runDaemonSocket sd workerHelper lsock k = do } -- TODO: this, but without the space leak - fmap fst $ concurrently listener $ processConnection workerHelper preStoreConfig + fmap fst + $ concurrently listener + $ processConnection workerHelper preStoreConfig either absurd id <$> race listener k @@ -71,10 +80,8 @@ runDaemonSocket sd workerHelper lsock k = do -- -- this function should take care to not throw errors from client connections. processConnection - :: ( MonadIO m - , MonadError RemoteStoreError m - , MonadReader StoreConfig m - ) + :: forall m + . MonadIO m => WorkerHelper m -> PreStoreConfig -> m () @@ -103,6 +110,22 @@ processConnection workerHelper preStoreConfig = do --authHook(*store); stopWork tunnelLogger + let perform + :: ( Show a + , StoreReply a + ) + => StoreRequest a + -> RemoteStoreT StoreConfig m (Identity a) + perform req = do + resp <- bracketLogger tunnelLogger $ lift $ workerHelper req + sockPutS + (mapErrorS + RemoteStoreError_SerializerReply + $ getReplyS + ) + resp + pure (Identity resp) + -- Process client requests. let loop = do someReq <- @@ -111,7 +134,26 @@ processConnection workerHelper preStoreConfig = do RemoteStoreError_SerializerRequest storeRequest - lift $ performOp' workerHelper tunnelLogger someReq + -- • Could not deduce (Show a) arising from a use of ‘perform’ + -- and also (StoreReply a) + -- traverseSome perform someReq + void $ do + case someReq of + Some req@(IsValidPath {}) -> do + -- • Couldn't match type ‘a0’ with ‘Bool’ + -- Expected: StoreRequest a0 + -- Actual: StoreRequest a + -- • ‘a0’ is untouchable + -- inside the constraints: a ~ Bool + -- bound by a pattern with constructor: + -- IsValidPath :: StorePath -> StoreRequest Bool + -- runIdentity <$> perform req + + void $ perform req + pure undefined + + _ -> throwError unimplemented + loop loop @@ -189,48 +231,9 @@ processConnection workerHelper preStoreConfig = do , serverHandshakeOutputClientVersion = clientVersion } -simpleOp - :: ( MonadIO m - , HasStoreSocket r - , HasProtoVersion r - , MonadError RemoteStoreError m - , MonadReader r m - ) - => (StoreRequest () -> m ()) - -> TunnelLogger r - -> m (StoreRequest ()) - -> m () -simpleOp workerHelper tunnelLogger m = do - req <- m - bracketLogger tunnelLogger $ workerHelper req - sockPutS - (mapErrorS - RemoteStoreError_SerializerPut - bool - ) - True - -simpleOpRet - :: ( MonadIO m - , HasStoreSocket r - , HasProtoVersion r - , MonadError RemoteStoreError m - , MonadReader r m - ) - => (StoreRequest a -> m a) - -> TunnelLogger r - -> NixSerializer r SError a - -> m (StoreRequest a) - -> m () -simpleOpRet workerHelper tunnelLogger s m = do - req <- m - resp <- bracketLogger tunnelLogger $ workerHelper req - sockPutS - (mapErrorS - RemoteStoreError_SerializerPut - s - ) - resp +{-# WARNING unimplemented "not yet implemented" #-} +unimplemented :: RemoteStoreError +unimplemented = RemoteStoreError_WorkerException $ WorkerException_Error $ WorkerError_NotYetImplemented bracketLogger :: ( MonadIO m @@ -248,34 +251,6 @@ bracketLogger tunnelLogger m = do stopWork tunnelLogger pure a -{-# WARNING unimplemented "not yet implemented" #-} -unimplemented :: WorkerException -unimplemented = WorkerException_Error $ WorkerError_NotYetImplemented - -performOp' - :: forall m - . ( MonadIO m - , MonadError RemoteStoreError m - , MonadReader StoreConfig m - ) - => WorkerHelper m - -> TunnelLogger StoreConfig - -> Some StoreRequest - -> m () -performOp' workerHelper tunnelLogger op = do - let _simpleOp' = simpleOp workerHelper tunnelLogger - let simpleOpRet' - :: NixSerializer StoreConfig SError a - -> m (StoreRequest a) - -> m () - simpleOpRet' = simpleOpRet workerHelper tunnelLogger - - case op of - Some (IsValidPath path) -> simpleOpRet' bool $ do - pure $ R.IsValidPath path - - _ -> undefined - --- data TunnelLogger r = TunnelLogger