[incubator-opendal] branch main updated: feat(bindings/haskell): add `Monad` wrapper (#2482)

[xu...@apache.org]

This is an automated email from the ASF dual-hosted git repository.

xuanwo pushed a commit to branch main
in repository https://gitbox.apache.org/repos/asf/incubator-opendal.git


The following commit(s) were added to refs/heads/main by this push:
     new fcda0be68 feat(bindings/haskell): add `Monad` wrapper (#2482)
fcda0be68 is described below

commit fcda0be68eb3d90bcaa68d9c2dc9c07d43b80a2d
Author: silver-ymz <yi...@gmail.com>
AuthorDate: Sun Jun 18 14:24:09 2023 +0800

    feat(bindings/haskell): add `Monad` wrapper (#2482)
    
    * feat(bindings/haskell): add `Monad` wrapper
    
    Signed-off-by: silver-ymz <yi...@gmail.com>
    
    * add tests for memory
    
    Signed-off-by: silver-ymz <yi...@gmail.com>
    
    * only test for memory
    
    Signed-off-by: silver-ymz <yi...@gmail.com>
    
    ---------
    
    Signed-off-by: silver-ymz <yi...@gmail.com>
---
 bindings/haskell/haskell-src/OpenDAL.hs | 102 +++++++++++++++++++++++++-------
 bindings/haskell/opendal-hs.cabal       |   4 +-
 bindings/haskell/test/BasicTest.hs      |  63 +++++++++++++-------
 3 files changed, 126 insertions(+), 43 deletions(-)

diff --git a/bindings/haskell/haskell-src/OpenDAL.hs b/bindings/haskell/haskell-src/OpenDAL.hs
index 5697b2ba3..293215a36 100644
--- a/bindings/haskell/haskell-src/OpenDAL.hs
+++ b/bindings/haskell/haskell-src/OpenDAL.hs
@@ -14,21 +14,27 @@
 -- KIND, either express or implied.  See the License for the
 -- specific language governing permissions and limitations
 -- under the License.
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module OpenDAL (
   Operator,
-  OpenDALError,
+  OpenDALError (..),
   ErrorCode (..),
+  OpMonad,
+  MonadOperation (..),
+  runOp,
   newOp,
-  readOp,
-  writeOp,
-  isExistOp,
-  createDirOp,
-  copyOp,
-  renameOp,
-  deleteOp,
+  readOpRaw,
+  writeOpRaw,
+  isExistOpRaw,
+  createDirOpRaw,
+  copyOpRaw,
+  renameOpRaw,
+  deleteOpRaw,
 ) where
 
+import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)
+import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, ask, liftIO, runReaderT)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import Data.HashMap.Strict (HashMap)
@@ -57,6 +63,55 @@ data ErrorCode
 data OpenDALError = OpenDALError {errorCode :: ErrorCode, message :: String}
   deriving (Eq, Show)
 
+newtype OpMonad a = OpMonad (ReaderT Operator (ExceptT OpenDALError IO) a)
+  deriving
+    ( Functor
+    , Applicative
+    , Monad
+    , MonadReader Operator
+    , MonadError OpenDALError
+    , MonadIO
+    )
+
+class (Monad m) => MonadOperation m where
+  readOp :: String -> m ByteString
+  writeOp :: String -> ByteString -> m ()
+  isExistOp :: String -> m Bool
+  createDirOp :: String -> m ()
+  copyOp :: String -> String -> m ()
+  renameOp :: String -> String -> m ()
+  deleteOp :: String -> m ()
+
+instance MonadOperation OpMonad where
+  readOp path = do
+    op <- ask
+    result <- liftIO $ readOpRaw op path
+    either throwError return result
+  writeOp path byte = do
+    op <- ask
+    result <- liftIO $ writeOpRaw op path byte
+    either throwError return result
+  isExistOp path = do
+    op <- ask
+    result <- liftIO $ isExistOpRaw op path
+    either throwError return result
+  createDirOp path = do
+    op <- ask
+    result <- liftIO $ createDirOpRaw op path
+    either throwError return result
+  copyOp src dst = do
+    op <- ask
+    result <- liftIO $ copyOpRaw op src dst
+    either throwError return result
+  renameOp src dst = do
+    op <- ask
+    result <- liftIO $ renameOpRaw op src dst
+    either throwError return result
+  deleteOp path = do
+    op <- ask
+    result <- liftIO $ deleteOpRaw op path
+    either throwError return result
+
 byteSliceToByteString :: ByteSlice -> IO ByteString
 byteSliceToByteString (ByteSlice bsDataPtr len) = BS.packCStringLen (bsDataPtr, fromIntegral len)
 
@@ -74,6 +129,9 @@ parseErrorCode 10 = RateLimited
 parseErrorCode 11 = IsSameFile
 parseErrorCode _ = FFIError
 
+runOp :: Operator -> OpMonad a -> IO (Either OpenDALError a)
+runOp operator (OpMonad op) = runExceptT $ runReaderT op operator
+
 -- | Create a new Operator.
 newOp :: String -> HashMap String String -> IO (Either OpenDALError Operator)
 newOp scheme hashMap = do
@@ -97,8 +155,8 @@ newOp scheme hashMap = do
                   errMsg <- peekCString (errorMessage ffiResult)
                   return $ Left $ OpenDALError code errMsg
 
-readOp :: Operator -> String -> IO (Either OpenDALError ByteString)
-readOp (Operator op) path = withForeignPtr op $ \opptr ->
+readOpRaw :: Operator -> String -> IO (Either OpenDALError ByteString)
+readOpRaw (Operator op) path = withForeignPtr op $ \opptr ->
   withCString path $ \cPath ->
     alloca $ \ffiResultPtr -> do
       c_blocking_read opptr cPath ffiResultPtr
@@ -114,8 +172,8 @@ readOp (Operator op) path = withForeignPtr op $ \opptr ->
           errMsg <- peekCString (errorMessage ffiResult)
           return $ Left $ OpenDALError code errMsg
 
-writeOp :: Operator -> String -> ByteString -> IO (Either OpenDALError ())
-writeOp (Operator op) path byte = withForeignPtr op $ \opptr ->
+writeOpRaw :: Operator -> String -> ByteString -> IO (Either OpenDALError ())
+writeOpRaw (Operator op) path byte = withForeignPtr op $ \opptr ->
   withCString path $ \cPath ->
     BS.useAsCStringLen byte $ \(cByte, len) ->
       alloca $ \ffiResultPtr -> do
@@ -128,8 +186,8 @@ writeOp (Operator op) path byte = withForeignPtr op $ \opptr ->
             errMsg <- peekCString (errorMessage ffiResult)
             return $ Left $ OpenDALError code errMsg
 
-isExistOp :: Operator -> String -> IO (Either OpenDALError Bool)
-isExistOp (Operator op) path = withForeignPtr op $ \opptr ->
+isExistOpRaw :: Operator -> String -> IO (Either OpenDALError Bool)
+isExistOpRaw (Operator op) path = withForeignPtr op $ \opptr ->
   withCString path $ \cPath ->
     alloca $ \ffiResultPtr -> do
       c_blocking_is_exist opptr cPath ffiResultPtr
@@ -145,8 +203,8 @@ isExistOp (Operator op) path = withForeignPtr op $ \opptr ->
           errMsg <- peekCString (errorMessage ffiResult)
           return $ Left $ OpenDALError code errMsg
 
-createDirOp :: Operator -> String -> IO (Either OpenDALError ())
-createDirOp (Operator op) path = withForeignPtr op $ \opptr ->
+createDirOpRaw :: Operator -> String -> IO (Either OpenDALError ())
+createDirOpRaw (Operator op) path = withForeignPtr op $ \opptr ->
   withCString path $ \cPath ->
     alloca $ \ffiResultPtr -> do
       c_blocking_create_dir opptr cPath ffiResultPtr
@@ -158,8 +216,8 @@ createDirOp (Operator op) path = withForeignPtr op $ \opptr ->
           errMsg <- peekCString (errorMessage ffiResult)
           return $ Left $ OpenDALError code errMsg
 
-copyOp :: Operator -> String -> String -> IO (Either OpenDALError ())
-copyOp (Operator op) srcPath dstPath = withForeignPtr op $ \opptr ->
+copyOpRaw :: Operator -> String -> String -> IO (Either OpenDALError ())
+copyOpRaw (Operator op) srcPath dstPath = withForeignPtr op $ \opptr ->
   withCString srcPath $ \cSrcPath ->
     withCString dstPath $ \cDstPath ->
       alloca $ \ffiResultPtr -> do
@@ -172,8 +230,8 @@ copyOp (Operator op) srcPath dstPath = withForeignPtr op $ \opptr ->
             errMsg <- peekCString (errorMessage ffiResult)
             return $ Left $ OpenDALError code errMsg
 
-renameOp :: Operator -> String -> String -> IO (Either OpenDALError ())
-renameOp (Operator op) srcPath dstPath = withForeignPtr op $ \opptr ->
+renameOpRaw :: Operator -> String -> String -> IO (Either OpenDALError ())
+renameOpRaw (Operator op) srcPath dstPath = withForeignPtr op $ \opptr ->
   withCString srcPath $ \cSrcPath ->
     withCString dstPath $ \cDstPath ->
       alloca $ \ffiResultPtr -> do
@@ -186,8 +244,8 @@ renameOp (Operator op) srcPath dstPath = withForeignPtr op $ \opptr ->
             errMsg <- peekCString (errorMessage ffiResult)
             return $ Left $ OpenDALError code errMsg
 
-deleteOp :: Operator -> String -> IO (Either OpenDALError ())
-deleteOp (Operator op) path = withForeignPtr op $ \opptr ->
+deleteOpRaw :: Operator -> String -> IO (Either OpenDALError ())
+deleteOpRaw (Operator op) path = withForeignPtr op $ \opptr ->
   withCString path $ \cPath ->
     alloca $ \ffiResultPtr -> do
       c_blocking_delete opptr cPath ffiResultPtr
diff --git a/bindings/haskell/opendal-hs.cabal b/bindings/haskell/opendal-hs.cabal
index dce0fb162..25351697b 100644
--- a/bindings/haskell/opendal-hs.cabal
+++ b/bindings/haskell/opendal-hs.cabal
@@ -43,7 +43,8 @@ library
     build-depends:
         base >=4.10.0.0 && <5,
         unordered-containers >=0.2.0.0, 
-        bytestring >=0.11.0.0
+        bytestring >=0.11.0.0,
+        mtl >=2.2.0.0
 
 test-suite opendal-hs-test
     type:             exitcode-stdio-1.0
@@ -56,6 +57,7 @@ test-suite opendal-hs-test
     build-depends:    
         base,
         unordered-containers,
+        mtl,
         opendal-hs,
         tasty,
         tasty-hunit
\ No newline at end of file
diff --git a/bindings/haskell/test/BasicTest.hs b/bindings/haskell/test/BasicTest.hs
index 135a5e6fe..8c1197ff4 100644
--- a/bindings/haskell/test/BasicTest.hs
+++ b/bindings/haskell/test/BasicTest.hs
@@ -18,6 +18,7 @@
 
 module BasicTest (basicTests) where
 
+import Control.Monad.IO.Class (liftIO)
 import qualified Data.HashMap.Strict as HashMap
 import OpenDAL
 import Test.Tasty
@@ -27,25 +28,47 @@ basicTests :: TestTree
 basicTests =
   testGroup
     "Basic Tests"
-    [ testCase "testBasicOperation" testBasicOperation
+    [ testCase "testBasicOperation" testRawOperation
+    , testCase "testMonad" testMonad
+    , testCase "testError" testError
     ]
 
-testBasicOperation :: Assertion
-testBasicOperation = do
-  Right op <- newOp "fs" $ HashMap.fromList [("root", "/tmp/opendal-test")]
-  writeOp op "key1" "value1" >>= (@?= Right ())
-  writeOp op "key2" "value2" >>= (@?= Right ())
-  readOp op "key1" >>= (@?= Right "value1")
-  readOp op "key2" >>= (@?= Right "value2")
-  isExistOp op "key1" >>= (@?= Right True)
-  isExistOp op "key2" >>= (@?= Right True)
-  createDirOp op "dir1/" >>= (@?= Right ())
-  isExistOp op "dir1/" >>= (@?= Right True)
-  copyOp op "key1" "key3" >>= (@?= Right ())
-  isExistOp op "key3" >>= (@?= Right True)
-  isExistOp op "key1" >>= (@?= Right True)
-  renameOp op "key2" "key4" >>= (@?= Right ())
-  isExistOp op "key4" >>= (@?= Right True)
-  isExistOp op "key2" >>= (@?= Right False)
-  deleteOp op "key1" >>= (@?= Right ())
-  isExistOp op "key1" >>= (@?= Right False)
\ No newline at end of file
+testRawOperation :: Assertion
+testRawOperation = do
+  Right op <- newOp "memory" HashMap.empty
+  writeOpRaw op "key1" "value1" >>= (@?= Right ())
+  writeOpRaw op "key2" "value2" >>= (@?= Right ())
+  readOpRaw op "key1" >>= (@?= Right "value1")
+  readOpRaw op "key2" >>= (@?= Right "value2")
+  isExistOpRaw op "key1" >>= (@?= Right True)
+  isExistOpRaw op "key2" >>= (@?= Right True)
+  createDirOpRaw op "dir1/" >>= (@?= Right ())
+  isExistOpRaw op "dir1/" >>= (@?= Right True)
+  deleteOpRaw op "key1" >>= (@?= Right ())
+  isExistOpRaw op "key1" >>= (@?= Right False)
+
+testMonad :: Assertion
+testMonad = do
+  Right op <- newOp "memory" HashMap.empty
+  runOp op operation >>= (@?= Right ())
+ where
+  operation = do
+    writeOp "key1" "value1"
+    writeOp "key2" "value2"
+    readOp "key1" >>= liftIO . (@?= "value1")
+    readOp "key2" >>= liftIO . (@?= "value2")
+    isExistOp "key1" >>= liftIO . (@?= True)
+    isExistOp "key2" >>= liftIO . (@?= True)
+    createDirOp "dir1/"
+    isExistOp "dir1/" >>= liftIO . (@?= True)
+    deleteOp "key1"
+    isExistOp "key1" >>= liftIO . (@?= False)
+
+testError :: Assertion
+testError = do
+  Right op <- newOp "memory" HashMap.empty
+  runOp op operation >>= \v -> case v of
+    Left err -> errorCode err @?= NotFound
+    Right _ -> assertFailure "should not reach here"
+ where
+  operation = readOp "non-exist-path"