wip/remote: add daemon runners, simplify server using StoreReply

Author: sorki

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

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

hnix-store-remote/src/System/Nix/Store/Remote/Server.hs

@@ -22,25 +22,32 @@ 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.
 runDaemonSocket
   :: forall m a
   . ( MonadIO m
     , MonadConc m
-    , MonadError RemoteStoreError m
-    , MonadReader StoreConfig m
     )
   => StoreDir
   -> WorkerHelper m
@@ -63,18 +70,18 @@ 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
 
 -- | "main loop" of the daemon for a single connection.
 --
 -- 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