Initial commit

.gitignore

@@ -1,11 +1,4 @@
+.ghci
+.cabal-sandbox
 dist
-cabal-dev
-*.o
-*.hi
-*.chi
-*.chs.h
-.virtualenv
-.hsenv
-.cabal-sandbox/
 cabal.sandbox.config
-cabal.config

Database/Cayley/Client.hs

@@ -0,0 +1,161 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Database.Cayley.Client
+    ( defaultCayleyConfig
+    , connectCayley
+    , query
+    , writeQuad
+    , deleteQuad
+    , writeQuads
+    , deleteQuads
+    , writeNQuadFile
+    , successfulResults
+    ) where
+
+import Control.Applicative ((<|>))
+import Control.Lens.Fold ((^?))
+import Control.Monad.Catch
+import Control.Monad.Reader
+import qualified Data.Aeson as A
+import Data.Aeson.Lens (key)
+import qualified Data.Attoparsec.Text as AT
+import Data.Maybe (fromJust)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Network.HTTP.Client
+import Network.HTTP.Client.MultipartFormData
+
+import Database.Cayley.Internal
+import Database.Cayley.Types
+
+-- | Get a connection to Cayley with the given configuration.
+--
+-- >λ> conn <- connectCayley defaultCayleyConfig
+--
+connectCayley :: CayleyConfig -> IO CayleyConnection
+connectCayley c =
+    newManager defaultManagerSettings >>= \m -> return $ CayleyConnection (c,m)
+
+-- | Perform a query in Gremlin graph query language per default (or in MQL).
+--
+-- >λ> query conn "graph.Vertex('Humphrey Bogart').In('name').All()"
+-- >Right (Array (fromList [Object (fromList [("id",String "/en/humphrey_bogart")])]))
+--
+query :: CayleyConnection -> T.Text -> IO (Either String A.Value)
+query c q =
+    runReaderT (doQuery (getManager c) (encodeUtf8 q)) (getConfig c)
+  where
+    doQuery m q = do
+        c <- ask
+        r <- apiRequest
+                 m ("http://" ++ serverName c ++ "/api/v" ++
+                    apiVersion c ++ "/query/" ++ queryLang c)
+                 (serverPort c) (RequestBodyBS q)
+        case r of
+            Just a  ->
+                case a ^? key "result" of
+                    Just v  -> return $ Right v
+                    Nothing ->
+                      case a ^? key "error" of
+                          Just e  ->
+                              case A.fromJSON e of
+                                  A.Success s -> return $ Left s
+                                  A.Error e   -> return $ Left e
+                          Nothing ->
+                              return $ Left "No JSON response from Cayley"
+            Nothing -> return $ Left "Can't get any response from Cayley"
+
+-- | Write a 'Quad' with the given subject, predicate, object and optional
+-- label. Throw result or extract amount of query 'successfulResults'
+-- from it.
+--
+-- >λ> writeQuad conn "Humphrey" "loves" "Lauren" (Just "In love")
+-- >Just (Object (fromList [("result",String "Successfully wrote 1 triples.")]))
+--
+writeQuad :: CayleyConnection
+          -> T.Text             -- ^ Subject node
+          -> T.Text             -- ^ Predicate node
+          -> T.Text             -- ^ Object node
+          -> Maybe T.Text       -- ^ Label node
+          -> IO (Maybe A.Value)
+writeQuad c s p o l =
+   writeQuads c [Quad { subject = s, predicate = p, object = o, label = l }]
+
+-- | Delete the 'Quad' defined by the given subject, predicate, object
+-- and optional label.
+deleteQuad :: CayleyConnection
+           -> T.Text
+           -> T.Text
+           -> T.Text
+           -> Maybe T.Text
+           -> IO (Maybe A.Value)
+deleteQuad c s p o l =
+    deleteQuads c [Quad { subject = s, predicate = p, object = o, label = l }]
+
+-- | Write the given list of 'Quad'(s).
+writeQuads :: CayleyConnection -> [Quad] -> IO (Maybe A.Value)
+writeQuads c qs =
+    runReaderT (write (getManager c) qs) (getConfig c)
+  where
+    write m qs = do
+        c <- ask
+        apiRequest
+            m ("http://" ++ serverName c ++
+               "/api/v" ++ apiVersion c ++ "/write")
+            (serverPort c) (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)
+  where
+    delete m qs = do
+        c <- ask
+        apiRequest
+            m ("http://" ++ serverName c ++
+               "/api/v" ++ apiVersion c ++ "/delete")
+            (serverPort c)
+            (toRequestBody qs)
+
+-- | Write a N-Quad file.
+writeNQuadFile c p =
+    runReaderT (writenq (getManager c) p) (getConfig c)
+  where
+    writenq m p = do
+        c <- ask
+        r <- parseUrl ("http://" ++ serverName c ++ "/api/v"
+                       ++ apiVersion c ++ "/write/file/nquad")
+                 >>= \r -> return r { port = serverPort c}
+        t <- liftIO $
+                 try $
+                    flip httpLbs m
+                        =<< formDataBody [partFileSource "NQuadFile" p] r
+        case t of
+            Right r -> return $ A.decode $ responseBody r
+            Left e  ->
+                return $
+                    Just $
+                        A.object
+                            ["error" A..= T.pack (show (e :: SomeException))]
+
+-- | Get amount of successful results from a write/delete 'Quad'(s)
+-- operation.
+--
+-- >λ> writeNQuadFile conn "testdata.nq" >>= successfulResults
+-- >Right 9
+--
+successfulResults :: Maybe A.Value -> IO (Either String Int)
+successfulResults v =
+    case A.fromJSON (fromJust $ fromJust v ^? key "result") of
+        A.Success s ->
+            case AT.parse getAmount s of
+                AT.Done "" a -> return $ Right a
+                _ -> return $ Left "Can't get amount of successful results"
+        A.Error e -> return $ Left e
+  where
+    getAmount = do
+        AT.string "Successfully "
+        AT.string "deleted " <|> AT.string "wrote "
+        a <- AT.decimal
+        AT.string " triples."
+        return a

Database/Cayley/Internal.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Database.Cayley.Internal where
+
+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)
+import Network.HTTP.Client
+
+import Database.Cayley.Types
+
+apiRequest :: Manager -> String -> Int -> RequestBody -> ReaderT CayleyConfig IO (Maybe A.Value)
+apiRequest m u p b = do
+    r <- parseUrl u >>= \c ->
+             return c { method = "POST", port = p, requestBody = b }
+    t <- liftIO $ try $ httpLbs r m
+    case t of
+        Right r -> return $ A.decode $ responseBody r
+        Left e  ->
+            return $
+                Just $
+                    A.object ["error" A..= T.pack (show (e :: SomeException))]
+
+toRequestBody :: [Quad] -> RequestBody
+toRequestBody qs = RequestBodyLBS $ A.encode $ fromList $ map A.toJSON qs
+
+getManager (CayleyConnection (_,m)) = m
+
+getConfig (CayleyConnection (c,_)) = c

Database/Cayley/Types.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Database.Cayley.Types where
+
+import qualified Data.Aeson as A
+import Control.Applicative
+import Control.Monad
+import qualified Data.Text as T
+import Network.HTTP.Client (Manager)
+
+data CayleyConfig = CayleyConfig
+    { serverPort :: Int    -- ^ Default to 64210
+    , serverName :: String -- ^ Default to "localhost"
+    , apiVersion :: String -- ^ Default to "1"
+    , queryLang  :: String -- ^ Default to "gremlin"
+    } deriving (Eq,Show)
+
+-- | CayleyConfig { serverPort = 64210 , serverName = "localhost" , apiVersion = "1" , queryLang  = "gremlin" }
+defaultCayleyConfig = CayleyConfig
+    { serverPort = 64210
+    , serverName = "localhost"
+    , apiVersion = "1"
+    , queryLang  = "gremlin"
+    }
+
+data CayleyConnection = CayleyConnection (CayleyConfig,Manager)
+
+data Quad = Quad
+    { subject   :: T.Text       -- ^ Subject node
+    , predicate :: T.Text       -- ^ Predicate node
+    , object    :: T.Text       -- ^ Object node
+    , label     :: Maybe T.Text -- ^ Label node
+    } deriving (Eq,Show)
+
+instance A.ToJSON Quad where
+    toJSON (Quad subject predicate object label) =
+        A.object [ "subject"   A..= subject
+                 , "predicate" A..= predicate
+                 , "object"    A..= object
+                 , "label"     A..= label
+                 ]
+
+instance A.FromJSON Quad where
+    parseJSON (A.Object v) = Quad <$>
+                             v A..: "subject" <*>
+                             v A..: "predicate" <*>
+                             v A..: "object" <*>
+                             v A..: "label"
+    parseJSON _            = mzero

README.md

@@ -0,0 +1,3 @@
+#A Cayley client for Haskell
+
+Cayley-client is an Haskell library that implements the [RESTful API](https://github.com/google/cayley/blob/master/docs/HTTP.md) of [Cayley database graph](https://github.com/google/cayley).

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

cayley-client.cabal

@@ -0,0 +1,24 @@
+name:                cayley-client
+version:             0.1.0.0
+stability:           Experimental
+synopsis:            An Haskell client for Cayley graph database
+description:         cayley-client implements the RESTful API of the Cayley database graph.
+homepage:            http://mb.cybervisible.fr/haskell-cayley-client
+license:             BSD3
+license-file:        LICENSE
+author:              Michel Boucey
+maintainer:          [email protected]
+copyright:           Copyright © 2015 - Michel Boucey
+category:            Database
+build-type:          Simple
+cabal-version:       >=1.10
+
+Source-Repository head
+  Type: git
+  Location: https://github.com/MichelBoucey/cayley-client
+
+library
+  exposed-modules:     Database.Cayley.Client
+  other-extensions:    OverloadedStrings
+  build-depends:       base >=4.7 && <4.8, mtl >=2.1 && <2.2, transformers >=0.3 && <0.4, attoparsec >=0.12 && <0.13, bytestring >=0.10 && <0.11, text >=1.2 && <1.3, vector >=0.10 && <0.11, http-conduit >=2.1 && <2.2, http-client >=0.4 && <0.5, aeson >=0.8 && <0.9, lens >= 4.6.0.1, lens-aeson >=1.0.0.3, unordered-containers >=0.2 && <0.3, exceptions >= 0.6 && <0.7
+  default-language:    Haskell2010