Lift the monad stack to a monad stack transformer

Author: layus

hnix-store-remote/hnix-store-remote.cabal

@@ -30,22 +30,22 @@ library
                      , System.Nix.Store.Remote.Types
                      , System.Nix.Store.Remote.Util
 
-  build-depends:       base >=4.10 && <5
-                     , attoparsec
-                     , bytestring
+  build-depends:       attoparsec
+                     , base >=4.10 && <5
                      , binary
                      , bytestring
                      , containers
                      , filepath
-                     , text
-                     , unix
+                     , hnix-store-core
+                     , lifted-base
+                     , monad-control
+                     , mtl
                      , network
                      , nix-derivation >= 1.1.1 && <2
-                     , mtl
-                     , unordered-containers
-                     , filepath
+                     , text
                      , time
-                     , hnix-store-core
+                     , unix
+                     , unordered-containers
                      , vector
   hs-source-dirs:      src
   default-language:    Haskell2010

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

@@ -9,7 +9,9 @@
 {-# LANGUAGE RecordWildCards     #-}
 module System.Nix.Store.Remote
   (
-    addToStore
+    MonadStoreT
+  , MonadStore
+  , addToStore
   , addTextToStore
   , addSignatures
   , addIndirectRoot
@@ -37,6 +39,7 @@ module System.Nix.Store.Remote
   where
 
 import Control.Monad (void, unless, when)
+import Control.Monad.IO.Class (MonadIO)
 import Data.ByteString.Lazy (ByteString)
 import Data.Map.Strict (Map)
 import Data.Text (Text)
@@ -72,13 +75,13 @@ type CheckSigsFlag = Bool
 type SubstituteFlag = Bool
 
 -- | Pack `FilePath` as `Nar` and add it to the store.
-addToStore :: forall a. (ValidAlgo a, NamedAlgo a)
+addToStore :: forall a m. (ValidAlgo a, NamedAlgo a, MonadIO m)
            => StorePathName        -- ^ Name part of the newly created `StorePath`
            -> FilePath             -- ^ Local `FilePath` to add
            -> Bool                 -- ^ Add target directory recursively
            -> (FilePath -> Bool)   -- ^ Path filter function
            -> RepairFlag           -- ^ Only used by local store backend
-           -> MonadStore StorePath
+           -> MonadStoreT m StorePath
 addToStore name pth recursive _pathFilter _repair = do
 
   runOpArgsIO AddToStore $ \yield -> do
@@ -101,11 +104,12 @@ addToStore name pth recursive _pathFilter _repair = do
 --
 -- Reference accepts repair but only uses it
 -- to throw error in case of remote talking to nix-daemon.
-addTextToStore :: Text         -- ^ Name of the text
+addTextToStore :: (MonadIO m)
+               => Text         -- ^ Name of the text
                -> Text         -- ^ Actual text to add
                -> StorePathSet -- ^ Set of `StorePath`s that the added text references
                -> RepairFlag   -- ^ Repair flag, must be `False` in case of remote backend
-               -> MonadStore StorePath
+               -> MonadStoreT m StorePath
 addTextToStore name text references' repair = do
   when repair $ error "repairing is not supported when building through the Nix daemon"
   runOpArgs AddTextToStore $ do
@@ -156,7 +160,7 @@ buildDerivation p drv buildMode = do
     -- XXX: reason for this is unknown
     -- but without it protocol just hangs waiting for
     -- more data. Needs investigation
-    putInt 0
+    putInt (0 :: Int)
 
   res <- getSocketIncremental $ getBuildResult
   return res
@@ -172,7 +176,7 @@ findRoots = do
   sd <- getStoreDir
   res <- getSocketIncremental
     $ getMany
-    $ (,) <$> (Data.ByteString.Lazy.fromStrict <$> getByteStringLen) 
+    $ (,) <$> (Data.ByteString.Lazy.fromStrict <$> getByteStringLen)
           <*> getPath sd
 
   r <- catRights res

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module System.Nix.Store.Remote.Logger (
     Logger(..)
   , Field(..)
@@ -30,16 +31,16 @@ controlParser = do
     0x52534c54 -> Result        <$> getInt <*> getInt <*> getFields
     x          -> fail           $ "Invalid control message received:" ++ show x
 
-processOutput :: MonadStore [Logger]
+processOutput :: MonadIO m => MonadStoreT m [Logger]
 processOutput = go decoder
   where decoder = runGetIncremental controlParser
-        go :: Decoder Logger -> MonadStore [Logger]
+        go :: MonadIO m => Decoder Logger -> MonadStoreT m [Logger]
         go (Done _leftover _consumed ctrl) = do
           case ctrl of
             e@(Error _ _) -> return [e]
             Last -> return [Last]
             Read _n -> do
-              (mdata, _) <- get
+              (mdata, _) <- NixStore get
               case mdata of
                 Nothing -> throwError "No data to read provided"
                 Just part -> do
@@ -55,7 +56,7 @@ processOutput = go decoder
               next <- go decoder
               return $ x:next
         go (Partial k) = do
-          soc <- storeSocket <$> ask
+          soc <- storeSocket <$> NixStore ask
           chunk <- liftIO (Just <$> recv soc 8)
           go (k chunk)
 

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE FlexibleContexts #-}
 module System.Nix.Store.Remote.Protocol (
     WorkerOp(..)
   , simpleOp
@@ -15,6 +16,7 @@ import           Control.Exception         (bracket)
 import           Control.Monad.Except
 import           Control.Monad.Reader
 import           Control.Monad.State
+import           Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp)
 
 import           Data.Binary.Get
 import           Data.Binary.Put
@@ -114,25 +116,27 @@ opNum AddToStoreNar               = 39
 opNum QueryMissing                = 40
 
 
-simpleOp :: WorkerOp -> MonadStore Bool
+simpleOp :: (MonadIO m) => WorkerOp -> MonadStoreT m Bool
 simpleOp op = do
   simpleOpArgs op $ return ()
 
-simpleOpArgs :: WorkerOp -> Put -> MonadStore Bool
+simpleOpArgs :: (MonadIO m) => WorkerOp -> Put -> MonadStoreT m Bool
 simpleOpArgs op args = do
   runOpArgs op args
   err <- gotError
   case err of
     True -> do
-      Error _num msg <- head <$> getError
-      throwError $ Data.ByteString.Char8.unpack msg
+      err  <- head <$> getError
+      case err of
+        Error _num msg -> throwError $ Data.ByteString.Char8.unpack msg
+        _ -> throwError $ "Well, it should really be an error by now"
     False -> do
       sockGetBool
 
-runOp :: WorkerOp -> MonadStore ()
+runOp :: (MonadIO m) => WorkerOp -> MonadStoreT m ()
 runOp op = runOpArgs op $ return ()
 
-runOpArgs :: WorkerOp -> Put -> MonadStore ()
+runOpArgs :: (MonadIO m) => WorkerOp -> Put -> MonadStoreT m ()
 runOpArgs op args = runOpArgsIO op (\encode -> encode $ Data.ByteString.Lazy.toStrict $ runPut args)
 
 runOpArgsIO :: WorkerOp -> ((Data.ByteString.ByteString -> MonadStore ()) -> MonadStore ()) -> MonadStore ()
@@ -145,18 +149,21 @@ runOpArgsIO op encoder = do
   encoder (liftIO . sendAll soc)
 
   out <- processOutput
-  modify (\(a, b) -> (a, b++out))
+  NixStore $ modify (\(a, b) -> (a, b++out))
   err <- gotError
   when err $ do
-    Error _num msg <- head <$> getError
-    throwError $ Data.ByteString.Char8.unpack msg
+    err  <- head <$> getError
+    case err of
+      Error _num msg -> throwError $ Data.ByteString.Char8.unpack msg
+      _ -> throwError $ "Well, it should really be an error by now"
 
-runStore :: MonadStore a -> IO (Either String a, [Logger])
+
+runStore :: (MonadIO m, MonadBaseControl IO m) => MonadStoreT m a -> m (Either String a, [Logger])
 runStore = runStoreOpts defaultSockPath "/nix/store"
 
-runStoreOpts :: FilePath -> FilePath -> MonadStore a -> IO (Either String a, [Logger])
+runStoreOpts :: (MonadIO m, MonadBaseControl IO m) => FilePath -> FilePath -> MonadStoreT m a -> m (Either String a, [Logger])
 runStoreOpts sockPath storeRootDir code = do
-  bracket (open sockPath) (Network.Socket.close . storeSocket) run
+  liftBaseOp (bracket (open sockPath) (Network.Socket.close . storeSocket)) run
   where
     open path = do
       soc <-
@@ -169,9 +176,10 @@ runStoreOpts sockPath storeRootDir code = do
       return $ StoreConfig { storeSocket = soc
                            , storeDir    = storeRootDir }
 
+    greet :: MonadIO m => MonadStoreT m [Logger]
     greet = do
       sockPut $ putInt workerMagic1
-      soc <- storeSocket <$> ask
+      soc <- storeSocket <$> NixStore ask
       vermagic <- liftIO $ recv soc 16
       let (magic2, _daemonProtoVersion) =
             flip runGet (Data.ByteString.Lazy.fromStrict vermagic)
@@ -189,4 +197,5 @@ runStoreOpts sockPath storeRootDir code = do
       fmap (\(res, (_data, logs)) -> (res, logs))
         $ flip runReaderT sock
         $ flip runStateT (Nothing, [])
-        $ runExceptT (greet >> code)
+        $ runExceptT
+        $ unStore (greet >> code)

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

@@ -2,8 +2,11 @@
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 module System.Nix.Store.Remote.Types (
     MonadStore
+  , MonadStoreT(..)
   , StoreConfig(..)
   , Logger(..)
   , Field(..)
@@ -20,16 +23,33 @@ module System.Nix.Store.Remote.Types (
 import           Data.ByteString           (ByteString)
 import qualified Data.ByteString.Lazy      as BSL
 import           Network.Socket            (Socket)
+import           Control.Applicative       (Alternative)
 import           Control.Monad.Except
 import           Control.Monad.Reader
 import           Control.Monad.State
+import           Control.Monad.Fail             ( MonadFail )
 
 data StoreConfig = StoreConfig {
     storeDir        :: FilePath
   , storeSocket     :: Socket
   }
 
-type MonadStore a = ExceptT String (StateT (Maybe BSL.ByteString, [Logger]) (ReaderT StoreConfig IO)) a
+newtype MonadStoreT m a = NixStore {
+    unStore :: ExceptT String (StateT (Maybe BSL.ByteString, [Logger]) (ReaderT StoreConfig m)) a
+  } deriving
+    ( Functor
+    , Applicative
+    , Alternative
+    , Monad
+    , MonadFail
+    , MonadError String
+    , MonadIO
+    )
+
+instance MonadTrans MonadStoreT where
+  lift = NixStore . lift . lift . lift
+
+type MonadStore a = MonadStoreT IO a
 
 type ActivityID = Int
 type ActivityParentID = Int
@@ -55,23 +75,23 @@ isError :: Logger -> Bool
 isError (Error _ _) = True
 isError _           = False
 
-gotError :: MonadStore Bool
-gotError = any isError . snd <$> get
+gotError :: (MonadIO m) => MonadStoreT m Bool
+gotError = any isError . snd <$> NixStore get
 
-getError :: MonadStore [Logger]
-getError = filter isError . snd <$> get
+getError :: (MonadIO m) => MonadStoreT m [Logger]
+getError = filter isError . snd <$> NixStore get
 
-getLog :: MonadStore [Logger]
-getLog = snd <$> get
+getLog :: (MonadIO m) => MonadStoreT m [Logger]
+getLog = snd <$> NixStore get
 
-flushLog :: MonadStore ()
-flushLog = modify (\(a, _b) -> (a, []))
+flushLog :: (MonadIO m) => MonadStoreT m ()
+flushLog = NixStore $ modify (\(a, _b) -> (a, []))
 
-setData :: BSL.ByteString -> MonadStore ()
-setData x = modify (\(_, b) -> (Just x, b))
+setData :: (MonadIO m) => BSL.ByteString -> MonadStoreT m ()
+setData x = NixStore $ modify (\(_, b) -> (Just x, b))
 
-clearData :: MonadStore ()
-clearData = modify (\(_, b) -> (Nothing, b))
+clearData :: (MonadIO m) => MonadStoreT m ()
+clearData = NixStore $ modify (\(_, b) -> (Nothing, b))
 
-getStoreDir :: MonadStore FilePath
-getStoreDir = storeDir <$> ask
+getStoreDir :: (MonadIO m) => MonadStoreT m FilePath
+getStoreDir = storeDir <$> NixStore ask

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

@@ -44,51 +44,51 @@ genericIncremental getsome parser = go decoder
     go (Fail _leftover _consumed msg) = do
       error msg
 
-getSocketIncremental :: Get a -> MonadStore a
+getSocketIncremental :: (MonadIO m) => Get a -> MonadStoreT m a
 getSocketIncremental = genericIncremental sockGet8
   where
-    sockGet8 :: MonadStore (Maybe BSC.ByteString)
+    sockGet8 :: (MonadIO m) => MonadStoreT m (Maybe BSC.ByteString)
     sockGet8 = do
-      soc <- storeSocket <$> ask
+      soc <- storeSocket <$> NixStore ask
       liftIO $ Just <$> recv soc 8
 
-sockPut :: Put -> MonadStore ()
+sockPut :: (MonadIO m) => Put -> MonadStoreT m ()
 sockPut p = do
-  soc <- storeSocket <$> ask
+  soc <- storeSocket <$> NixStore ask
   liftIO $ sendAll soc $ BSL.toStrict $ runPut p
 
-sockGet :: Get a -> MonadStore a
+sockGet :: (MonadIO m) => Get a -> MonadStoreT m a
 sockGet = getSocketIncremental
 
-sockGetInt :: Integral a => MonadStore a
+sockGetInt :: (MonadIO m) => Integral a => MonadStoreT m a
 sockGetInt = getSocketIncremental getInt
 
-sockGetBool :: MonadStore Bool
+sockGetBool :: (MonadIO m) => MonadStoreT m Bool
 sockGetBool = (== (1 :: Int)) <$> sockGetInt
 
-sockGetStr :: MonadStore ByteString
+sockGetStr :: (MonadIO m) => MonadStoreT m ByteString
 sockGetStr = getSocketIncremental getByteStringLen
 
-sockGetStrings :: MonadStore [ByteString]
+sockGetStrings :: (MonadIO m) => MonadStoreT m [ByteString]
 sockGetStrings = getSocketIncremental getByteStrings
 
-sockGetPath :: MonadStore StorePath
+sockGetPath :: (MonadIO m) => MonadStoreT m StorePath
 sockGetPath = do
   sd <- getStoreDir
   pth <- getSocketIncremental (getPath sd)
   case pth of
     Left e -> throwError e
     Right x -> return x
 
-sockGetPathMay :: MonadStore (Maybe StorePath)
+sockGetPathMay :: (MonadIO m) => MonadStoreT m (Maybe StorePath)
 sockGetPathMay = do
   sd <- getStoreDir
   pth <- getSocketIncremental (getPath sd)
   return $ case pth of
     Left _e -> Nothing
     Right x -> Just x
 
-sockGetPaths :: MonadStore StorePathSet
+sockGetPaths :: (MonadIO m) => MonadStoreT m StorePathSet
 sockGetPaths = do
   sd <- getStoreDir
   getSocketIncremental (getPaths sd)