mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-09-11 18:05:56 +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
|
, data-default-class
|
||||||
, dependent-sum > 0.7
|
, dependent-sum > 0.7
|
||||||
, dependent-sum-template >= 0.2.0.1 && < 0.3
|
, dependent-sum-template >= 0.2.0.1 && < 0.3
|
||||||
|
, directory
|
||||||
, dlist >= 1.0
|
, dlist >= 1.0
|
||||||
|
, exceptions
|
||||||
, generic-arbitrary < 1.1
|
, generic-arbitrary < 1.1
|
||||||
, hashable
|
, hashable
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
, network
|
, network
|
||||||
|
, monad-control
|
||||||
, mtl
|
, mtl
|
||||||
, QuickCheck
|
, QuickCheck
|
||||||
, unordered-containers
|
, unordered-containers
|
||||||
|
@ -1,6 +1,8 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE Rank2Types #-}
|
||||||
|
|
||||||
module System.Nix.Store.Remote
|
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.Client
|
||||||
, module System.Nix.Store.Remote.MonadStore
|
, module System.Nix.Store.Remote.MonadStore
|
||||||
, module System.Nix.Store.Remote.Types
|
, module System.Nix.Store.Remote.Types
|
||||||
@ -10,6 +12,10 @@ module System.Nix.Store.Remote
|
|||||||
, runStore
|
, runStore
|
||||||
, runStoreOpts
|
, runStoreOpts
|
||||||
, runStoreOptsTCP
|
, runStoreOptsTCP
|
||||||
|
-- ** Daemon
|
||||||
|
, runDaemon
|
||||||
|
, runDaemonOpts
|
||||||
|
, justdoit
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Default.Class (Default(def))
|
import Data.Default.Class (Default(def))
|
||||||
@ -23,6 +29,16 @@ import System.Nix.Store.Remote.Types
|
|||||||
import qualified Control.Exception
|
import qualified Control.Exception
|
||||||
import qualified Network.Socket
|
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
|
-- * Compat
|
||||||
|
|
||||||
type MonadStore = RemoteStoreT StoreConfig IO
|
type MonadStore = RemoteStoreT StoreConfig IO
|
||||||
@ -31,9 +47,9 @@ type MonadStore = RemoteStoreT StoreConfig IO
|
|||||||
|
|
||||||
runStore :: MonadStore a -> Run IO a
|
runStore :: MonadStore a -> Run IO a
|
||||||
runStore = runStoreOpts defaultSockPath def
|
runStore = runStoreOpts defaultSockPath def
|
||||||
where
|
|
||||||
defaultSockPath :: String
|
defaultSockPath :: String
|
||||||
defaultSockPath = "/nix/var/nix/daemon-socket/socket"
|
defaultSockPath = "/nix/var/nix/daemon-socket/socket"
|
||||||
|
|
||||||
runStoreOpts
|
runStoreOpts
|
||||||
:: FilePath
|
:: FilePath
|
||||||
@ -84,3 +100,71 @@ runStoreOpts' sockFamily sockAddr storeRootDir code =
|
|||||||
{ preStoreConfig_socket = soc
|
{ preStoreConfig_socket = soc
|
||||||
, preStoreConfig_dir = storeRootDir
|
, 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.Serializer as RB
|
||||||
import System.Nix.Store.Remote.Socket
|
import System.Nix.Store.Remote.Socket
|
||||||
import System.Nix.Store.Remote.Types.StoreRequest as R
|
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.StoreConfig (HasStoreSocket(..), StoreConfig(..), PreStoreConfig(..), preStoreConfigToStoreConfig)
|
||||||
import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..))
|
import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..))
|
||||||
import System.Nix.Store.Remote.Types.Logger (BasicError(..), ErrorInfo, Logger(..))
|
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.MonadStore (WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT, mapStoreConfig)
|
||||||
import System.Nix.Store.Remote.Types.Handshake (ServerHandshakeInput(..), ServerHandshakeOutput(..))
|
import System.Nix.Store.Remote.Types.Handshake (ServerHandshakeInput(..), ServerHandshakeOutput(..))
|
||||||
import System.Nix.Store.Remote.Types.ProtoVersion (ourProtoVersion)
|
import System.Nix.Store.Remote.Types.ProtoVersion (ourProtoVersion)
|
||||||
import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))
|
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.
|
-- | Run an emulated nix daemon on given socket address.
|
||||||
-- The deamon will close when the continuation returns.
|
-- The deamon will close when the continuation returns.
|
||||||
@ -39,8 +48,6 @@ runDaemonSocket
|
|||||||
:: forall m a
|
:: forall m a
|
||||||
. ( MonadIO m
|
. ( MonadIO m
|
||||||
, MonadConc m
|
, MonadConc m
|
||||||
, MonadError RemoteStoreError m
|
|
||||||
, MonadReader StoreConfig m
|
|
||||||
)
|
)
|
||||||
=> StoreDir
|
=> StoreDir
|
||||||
-> WorkerHelper m
|
-> WorkerHelper m
|
||||||
@ -63,7 +70,9 @@ runDaemonSocket sd workerHelper lsock k = do
|
|||||||
}
|
}
|
||||||
|
|
||||||
-- TODO: this, but without the space leak
|
-- 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
|
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.
|
-- this function should take care to not throw errors from client connections.
|
||||||
processConnection
|
processConnection
|
||||||
:: ( MonadIO m
|
:: forall m
|
||||||
, MonadError RemoteStoreError m
|
. MonadIO m
|
||||||
, MonadReader StoreConfig m
|
|
||||||
)
|
|
||||||
=> WorkerHelper m
|
=> WorkerHelper m
|
||||||
-> PreStoreConfig
|
-> PreStoreConfig
|
||||||
-> m ()
|
-> m ()
|
||||||
@ -103,6 +110,22 @@ processConnection workerHelper preStoreConfig = do
|
|||||||
--authHook(*store);
|
--authHook(*store);
|
||||||
stopWork tunnelLogger
|
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.
|
-- Process client requests.
|
||||||
let loop = do
|
let loop = do
|
||||||
someReq <-
|
someReq <-
|
||||||
@ -111,7 +134,26 @@ processConnection workerHelper preStoreConfig = do
|
|||||||
RemoteStoreError_SerializerRequest
|
RemoteStoreError_SerializerRequest
|
||||||
storeRequest
|
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
|
||||||
loop
|
loop
|
||||||
|
|
||||||
@ -189,48 +231,9 @@ processConnection workerHelper preStoreConfig = do
|
|||||||
, serverHandshakeOutputClientVersion = clientVersion
|
, serverHandshakeOutputClientVersion = clientVersion
|
||||||
}
|
}
|
||||||
|
|
||||||
simpleOp
|
{-# WARNING unimplemented "not yet implemented" #-}
|
||||||
:: ( MonadIO m
|
unimplemented :: RemoteStoreError
|
||||||
, HasStoreSocket r
|
unimplemented = RemoteStoreError_WorkerException $ WorkerException_Error $ WorkerError_NotYetImplemented
|
||||||
, 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
|
|
||||||
|
|
||||||
bracketLogger
|
bracketLogger
|
||||||
:: ( MonadIO m
|
:: ( MonadIO m
|
||||||
@ -248,34 +251,6 @@ bracketLogger tunnelLogger m = do
|
|||||||
stopWork tunnelLogger
|
stopWork tunnelLogger
|
||||||
pure a
|
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
|
data TunnelLogger r = TunnelLogger
|
||||||
|
Loading…
Reference in New Issue
Block a user