mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-08-17 13:51:21 +03:00
wip/remote: add daemon runners, simplify server using StoreReply
This commit is contained in:
parent
8078f0f07f
commit
2bdd171d22
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user