diff --git a/Database/Cayley/Client.hs b/Database/Cayley/Client.hs --- a/Database/Cayley/Client.hs +++ b/Database/Cayley/Client.hs @@ -50,7 +50,8 @@ -- connectCayley :: CayleyConfig -> IO CayleyConnection connectCayley c = - newManager defaultManagerSettings >>= \m -> return $ CayleyConnection (c,m) + newManager defaultManagerSettings + >>= \m -> return $ CayleyConnection { cayleyConfig = c, manager = m } -- | Perform a query, in Gremlin graph query language per default (or in MQL). -- @@ -60,16 +61,16 @@ query :: CayleyConnection -> Query -> IO (Either String A.Value) -query c q = - runReaderT (doQuery (getManager c) (encodeUtf8 q)) (getConfig c) +query CayleyConnection{..} = + doQuery manager cayleyConfig where - doQuery m _q = do - CayleyConfig{..} <- ask - r <- apiRequest - m (urlBase serverName apiVersion - ++ "/query/" ++ show queryLang) - serverPort (RequestBodyBS _q) - return $ case r of + doQuery m CayleyConfig{..} q = do + r <- apiRequest + m (urlBase serverName apiVersion + ++ "/query/" ++ show queryLang) + serverPort (RequestBodyBS $ encodeUtf8 q) + return $ + case r of Just a -> case a ^? L.key "result" of Just v -> Right v @@ -83,14 +84,13 @@ queryShape :: CayleyConnection -> Query -> IO (Either String Shape) -queryShape c q = - runReaderT (doShape (getManager c) (encodeUtf8 q)) (getConfig c) +queryShape CayleyConnection{..} = + doShape manager cayleyConfig where - doShape m _q = do - CayleyConfig{..} <- ask + doShape m CayleyConfig{..} q = do r <- apiRequest m (urlBase serverName apiVersion ++ "/shape/" ++ show queryLang) - serverPort (RequestBodyBS _q) + serverPort (RequestBodyBS $ encodeUtf8 q) return $ case r of Just o -> @@ -140,28 +140,25 @@ writeQuads :: CayleyConnection -> [Quad] -> IO (Maybe A.Value) -writeQuads c qs = - runReaderT (_write (getManager c) qs) (getConfig c) +writeQuads CayleyConnection{..} = + writeQuads' manager cayleyConfig where - _write m _qs = do - CayleyConfig{..} <- ask + writeQuads' m CayleyConfig{..} qs = apiRequest m (urlBase serverName apiVersion ++ "/write") - serverPort (toRequestBody _qs) + serverPort (toRequestBody qs) -- | Delete the given list of 'Quad'(s). deleteQuads :: CayleyConnection -> [Quad] -> IO (Maybe A.Value) -deleteQuads c qs = - runReaderT (_delete (getManager c) qs) (getConfig c) +deleteQuads CayleyConnection{..} = + doDeletions manager cayleyConfig where - _delete m _qs = do - CayleyConfig{..} <- ask + doDeletions m CayleyConfig{..} qs = apiRequest m (urlBase serverName apiVersion ++ "/delete") - serverPort - (toRequestBody _qs) + serverPort (toRequestBody qs) -- | Write a N-Quad file. -- @@ -172,21 +169,21 @@ => CayleyConnection -> FilePath -> m (Maybe A.Value) -writeNQuadFile c p = - runReaderT (writenq (getManager c) p) (getConfig c) +writeNQuadFile CayleyConnection{..} = + doWrite manager cayleyConfig where - writenq m _p = do - CayleyConfig{..} <- ask + doWrite m CayleyConfig{..} fp = do r <- parseRequest (urlBase serverName apiVersion ++ "/write/file/nquad") >>= \r -> return r { port = serverPort } t <- liftIO $ try $ flip httpLbs m - =<< formDataBody [partFileSource "NQuadFile" _p] r - return $ case t of - Right _r -> A.decode $ responseBody _r - Left e -> Just $ - A.object ["error" A..= T.pack (show (e :: SomeException))] + =<< formDataBody [partFileSource "NQuadFile" fp] r + return $ + case t of + Right b -> A.decode (responseBody b) + Left e -> Just $ + A.object ["error" A..= T.pack (show (e :: SomeException))] -- | A valid 'Quad' has its subject, predicate and object not empty. isValid :: Quad -> Bool diff --git a/Database/Cayley/Client/Internal.hs b/Database/Cayley/Client/Internal.hs --- a/Database/Cayley/Client/Internal.hs +++ b/Database/Cayley/Client/Internal.hs @@ -4,7 +4,6 @@ import Control.Monad.Catch import Control.Monad.IO.Class -import Control.Monad.Reader import qualified Data.Aeson as A import qualified Data.Text as T (pack) import Data.Vector (fromList) @@ -16,25 +15,19 @@ -> String -> Int -> RequestBody - -> ReaderT CayleyConfig IO (Maybe A.Value) + -> IO (Maybe A.Value) apiRequest m u p b = do r <- parseRequest u >>= \c -> return c { method = "POST", port = p, requestBody = b } - t <- liftIO $ try $ httpLbs r m + t <- liftIO (try $ httpLbs r m) case t of - Right _r -> return $ A.decode $ responseBody _r + Right r' -> return (A.decode $ responseBody r') Left e -> return $ Just $ A.object ["error" A..= T.pack (show (e :: SomeException))] toRequestBody :: [Quad] -> RequestBody toRequestBody = RequestBodyLBS . A.encode . fromList . map A.toJSON - -getManager :: CayleyConnection -> Manager -getManager (CayleyConnection (_,m)) = m - -getConfig :: CayleyConnection -> CayleyConfig -getConfig (CayleyConnection (c,_)) = c urlBase :: String -> APIVersion -> String urlBase s a = "http://" ++ s ++ "/api/v" ++ show a diff --git a/Database/Cayley/Types.hs b/Database/Cayley/Types.hs --- a/Database/Cayley/Types.hs +++ b/Database/Cayley/Types.hs @@ -39,7 +39,10 @@ , queryLang = Gremlin } -newtype CayleyConnection = CayleyConnection (CayleyConfig, Manager) +data CayleyConnection = CayleyConnection + { cayleyConfig :: CayleyConfig + , manager :: Manager + } data Quad = Quad { subject :: !T.Text -- ^ Subject node diff --git a/cayley-client.cabal b/cayley-client.cabal --- a/cayley-client.cabal +++ b/cayley-client.cabal @@ -1,45 +1,46 @@ -cabal-version: >=1.10 -name: cayley-client -version: 0.4.13 -license: BSD3 -license-file: LICENSE -copyright: (c) 2015-2020 - Michel Boucey -maintainer: michel.boucey@gmail.com -author: Michel Boucey -tested-with: ghc ==8.4.3 || ==8.6.5 || ==8.8.1 -homepage: https://github.com/MichelBoucey/cayley-client -synopsis: A Haskell client for the Cayley graph database +cabal-version: >=1.10 +name: cayley-client +version: 0.4.14 +license: BSD3 +license-file: LICENSE +copyright: (c) 2015-2021 - Michel Boucey +maintainer: michel.boucey@gmail.com +author: Michel Boucey +tested-with: ghc ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3 || ==8.10.1 +homepage: https://github.com/MichelBoucey/cayley-client +synopsis: A Haskell client for the Cayley graph database description: cayley-client implements the RESTful API of the Cayley graph database. -category: Database -build-type: Simple + +category: Database +build-type: Simple extra-source-files: README.md tests/testdata.nq source-repository head - type: git + type: git location: https://github.com/MichelBoucey/cayley-client.git library exposed-modules: Database.Cayley.Client Database.Cayley.Types - other-modules: - Database.Cayley.Client.Internal + + other-modules: Database.Cayley.Client.Internal default-language: Haskell2010 other-extensions: OverloadedStrings - ghc-options: -Wall + ghc-options: -Wall build-depends: aeson >=0.8.0.2 && <1.6, attoparsec >=0.12.1.6 && <0.14, base >=4.8.1.0 && <5, - bytestring >=0.10.6 && <0.11, - binary >=0.7.5 && <0.9, + bytestring >=0.10.6 && <0.12, + binary >=0.7.5 && <0.11, exceptions >=0.8.0.2 && <0.11, http-client >=0.4.30 && <0.8, http-conduit >=2.1.8 && <2.4, - lens >=4.12.3 && <4.20, + lens >=4.12.3 && <5.1, mtl >=2.2.1 && <2.3, lens-aeson >=1.0.0 && <1.2, text >=1.2.2 && <1.3, @@ -48,9 +49,9 @@ vector >=0.10.12.3 && <0.13 test-suite tests - type: exitcode-stdio-1.0 - main-is: hspec.hs - hs-source-dirs: tests + type: exitcode-stdio-1.0 + main-is: hspec.hs + hs-source-dirs: tests default-language: Haskell2010 build-depends: hspec >=2.1.10 && <3,