diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2015, Daishi Nakajima +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of gremlin-haskell nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,40 @@ +module Main where + +import Database.TinkerPop +import Database.TinkerPop.Types + +import Data.Text +import Data.Aeson +import Data.Aeson.Types + +import qualified Data.HashMap.Strict as H +import Control.Concurrent +import Control.Monad + +import Control.Monad.Trans (liftIO) + +import Control.Lens hiding ((.=), (.:)) +import Data.Aeson.Lens + + +main :: IO () +main = do + run "localhost" 8182 $ \conn -> do + -- DROP Database + submit conn "g.V().drop()" Nothing >>= print + let addV = "graph.addVertex(label, 'language', 'name', n)" + -- add 'haskell' vertex + haskell <- submit conn addV (Just $ H.fromList ["l" .= ("language" :: Text), "n" .= ("haskell" :: Text)]) + print haskell + let idHaskell = getId haskell + -- add (library) vertexes + yesod <- submit conn addV (Just $ H.fromList ["l" .= ("library" :: Text), "n" .= ("yesod" :: Text)]) + print yesod + let idYesod = getId yesod + idAeson <- getId <$> submit conn addV (Just $ H.fromList ["l" .= ("library" :: Text), "n" .= ("aeson" :: Text)]) + idLens <- getId <$> submit conn addV (Just $ H.fromList ["l" .= ("library" :: Text), "n" .= ("lens" :: Text)]) + -- add (library -written-> language) edge + mapM (\lib -> submit conn "g.V(from).next().addEdge('written', g.V(to).next())" (Just $ H.fromList ["from" .= lib, "to" .= idHaskell])) [idYesod, idHaskell, idLens] >>= print + -- query + submit conn "g.V().has('name', 'haskell').in('written').values()" Nothing >>= print + where getId = (^? _Right . element 0 . key "id" . _Integer) diff --git a/gremlin-haskell.cabal b/gremlin-haskell.cabal new file mode 100644 --- /dev/null +++ b/gremlin-haskell.cabal @@ -0,0 +1,73 @@ +name: gremlin-haskell +version: 0.1.0.0 +synopsis: Graph database client for TinkerPop3 Gremlin Server +description: Please see README.md +homepage: http://github.com/nakaji-dayo/gremlin-haskell +license: BSD3 +license-file: LICENSE +author: Daishi Nakajima +maintainer: nakaji.dayo@gmail.com +copyright: 2015 Daishi Nakajima +category: Database +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Database.TinkerPop + Database.TinkerPop.Types + Database.TinkerPop.Internal + ghc-options: -Wall -fwarn-tabs + default-extensions: OverloadedStrings + QuasiQuotes + TemplateHaskell + MultiParamTypeClasses + FunctionalDependencies + TypeSynonymInstances + FlexibleInstances + FlexibleContexts + build-depends: base >= 4.7 && < 5 + , text + , containers + , websockets + , lens + , aeson + , aeson-qq + , mtl + , stm + , uuid + default-language: Haskell2010 + +executable gremlin-haskell-examples + hs-source-dirs: examples + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-extensions: OverloadedStrings + build-depends: base + , gremlin-haskell + , text + , aeson + , lens + , lens-aeson + , unordered-containers + , mtl + default-language: Haskell2010 + +test-suite gremlin-haskell-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + default-extensions: OverloadedStrings + build-depends: base + , gremlin-haskell + , lens + , lens-aeson + , aeson-qq + , mtl + , hspec + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/nakaji-dayo/gremlin-haskell diff --git a/src/Database/TinkerPop.hs b/src/Database/TinkerPop.hs new file mode 100644 --- /dev/null +++ b/src/Database/TinkerPop.hs @@ -0,0 +1,66 @@ +-- | +-- Module: Database.TinkerPop +-- Copyright: (c) 2015 The gremlin-haskell Authors +-- License : BSD3 +-- Maintainer : nakaji.dayo@gmail.com +-- Stability : experimental +-- Portability : non-portable +-- +module Database.TinkerPop where + +import Database.TinkerPop.Types +import Database.TinkerPop.Internal + +import Prelude hiding (putStrLn) +import qualified Network.WebSockets as WS + +import qualified Data.Map.Strict as M +import Data.Text (unpack) +import Data.Aeson (encode, Value) +import qualified Control.Monad.STM as S +import qualified Control.Concurrent.STM.TChan as S +import qualified Control.Concurrent.STM.TVar as S +import qualified Data.UUID as U +import qualified Data.UUID.V4 as U +import Control.Lens + +-- | Connect to Gremlin Server +run :: String -> Int -> (Connection -> IO ()) -> IO () +run host port app = do + WS.runClient host port "/" $ \ws -> do + cs <- S.newTVarIO M.empty + let conn = Connection ws cs + _ <- handle conn + app conn + close conn + +-- | Send script toGremlin Server and get the result by List +-- +-- Individual responses are combined in internal. +submit :: Connection -> Gremlin -> Maybe Binding -> IO (Either String [Value]) +submit conn body binding = do + req <- buildRequest body binding + chan <- S.newTChanIO + S.atomically $ S.modifyTVar (conn ^. chans) $ M.insert (req ^. requestId) chan + WS.sendTextData (conn ^. socket) (encode req) + recv chan [] + where + recv chan xs = do + eres <- S.atomically $ S.readTChan chan + case eres of + Right r + | inStatus2xx statusCode -> do + let xs' = case (r ^. result ^. data') of + Just d -> xs ++ d + Nothing -> xs + if statusCode == 206 then recv chan xs' else return $ Right xs' + | otherwise -> return $ Left (unpack $ r ^. status ^. message) + where statusCode = (r ^. status ^. code) + Left x -> return $ Left x + +-- | Build request data +buildRequest :: Gremlin -> Maybe Binding -> IO RequestMessage +buildRequest body binding = do + uuid <- U.toText <$> U.nextRandom + return $ RequestMessage uuid "eval" "" $ + RequestArgs body binding "gremlin-groovy" Nothing diff --git a/src/Database/TinkerPop/Internal.hs b/src/Database/TinkerPop/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/TinkerPop/Internal.hs @@ -0,0 +1,40 @@ +module Database.TinkerPop.Internal where +import Database.TinkerPop.Types + +import Prelude hiding (putStrLn) +import Data.Text (Text, pack, append) +import Data.Text.IO +import Data.Text.Encoding +import qualified Data.Map.Strict as M +import qualified Control.Monad.STM as S +import qualified Control.Concurrent.STM.TChan as S +import qualified Control.Concurrent.STM.TVar as S +import Control.Concurrent +import Control.Monad (forever) +import Control.Lens +import Data.Aeson (eitherDecodeStrict) +import qualified Network.WebSockets as WS + +-- | check HTTP status code is success +inStatus2xx :: Int -> Bool +inStatus2xx x = (x `quot` 100) == 2 + +-- | Start thread to recieve response +handle :: Connection -> IO (ThreadId) +handle conn = do + forkIO $ forever $ do + msg <- WS.receiveData (conn ^. socket) :: IO Text +-- putStrLn $ "recv: " `append` msg + case eitherDecodeStrict (encodeUtf8 msg) of + Right r -> do + cs <- S.readTVarIO (conn ^. chans) + case M.lookup (r ^. requestId) cs of + Just chan -> S.atomically $ S.writeTChan chan (Right r) + Nothing -> putStrLn $ "ERROR: chan not found" + Left s -> putStrLn $ "ERROR: parse response message: " `append` (pack s) + +-- | Close connection +close :: Connection -> IO () +close conn = do +-- putStrLn "will close" + WS.sendClose (conn ^. socket) ("Bye!" :: Text) diff --git a/src/Database/TinkerPop/Types.hs b/src/Database/TinkerPop/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/TinkerPop/Types.hs @@ -0,0 +1,96 @@ +-- | +-- Module: Database.TinkerPop.Types +-- Copyright: (c) 2015 The gremlin-haskell Authors +-- License : BSD3 +-- Maintainer : nakaji.dayo@gmail.com +-- Stability : experimental +-- Portability : non-portable +-- +module Database.TinkerPop.Types where + +import Data.Text hiding (drop, toLower) +import Data.Char (toLower) +import qualified Data.Map.Strict as M +import Data.Aeson (Object, Value) +import Data.Aeson.TH +import Control.Lens + +import qualified Network.WebSockets as WS +import qualified Control.Concurrent.STM.TChan as S +import qualified Control.Concurrent.STM.TVar as S + +-- | Represent Gremlin code +type Gremlin = Text + +-- | A Map of key/value pairs +type Binding = Object + +-- | parameters to pass to Gremlin Server. (TODO: The requirements for the contents of this Map are dependent on the op selected.) +data RequestArgs = RequestArgs { + _requestArgsGremlin :: Text + -- ^ The Gremlin script to evaluate + , _requestArgsBindings :: Maybe Binding + -- ^ A map of key/value pairs to apply as variables in the context of the Gremlin script + , _requestArgsLanguage :: Text + -- ^ The flavor used (e.g. gremlin-groovy) + , _requestArgsBatchSize :: Maybe Int + -- ^ When the result is an iterator this value defines the number of iterations each ResponseMessage should contain +} +$(deriveJSON defaultOptions{fieldLabelModifier = (\(x:xs) -> (toLower x):xs).(drop 12)} ''RequestArgs) +makeFields ''RequestArgs + +-- | Format of requests to the Gremlin Server +data RequestMessage = RequestMessage { + _requestMessageRequestId :: Text + -- ^ A UUID representing the unique identification for the request. + , _requestMessageOp :: Text + -- ^ The name of the "operation" to execute based on the available OpProcessor configured in the Gremlin Server. To evaluate a script, use eval. + , _requestMessageProcessor :: Text + -- ^ The name of the OpProcessor to utilize. The default OpProcessor for evaluating scripts is unamed and therefore script evaluation purposes, this value can be an empty string. + , _requestMessageArgs :: RequestArgs + -- ^ Parameters to pass to Gremlin Server +} +$(deriveJSON defaultOptions{fieldLabelModifier = (\(x:xs) -> (toLower x):xs).(drop 15)} ''RequestMessage) +makeFields ''RequestMessage + +-- | The staus of Gremlin Server Response +data ResponseStatus = ResponseStatus { + _responseStatusMessage :: Text + -- ^ Human-readable String usually associated with errors. + , _responseStatusCode :: Int + -- ^ HTTP status code + , _responseStatusAttributes :: Object + -- ^ Protocol-level information +} deriving (Show) +makeFields ''ResponseStatus +$(deriveJSON defaultOptions {fieldLabelModifier = (\(x:xs) -> (toLower x):xs).(drop 15)} ''ResponseStatus) + +-- | The Result of Gremlin Server response +data ResponseResult = ResponseResult { + _responseResultData' :: Maybe [Value] + -- ^ the actual data returned from the server (the type of data is determined by the operation requested) + , _responseResultMeta :: Object + -- ^ Map of meta-data related to the response. +} deriving (Show) +makeFields ''ResponseResult +$(deriveJSON defaultOptions {fieldLabelModifier = \f -> if f == "_responseResultData'" then "data" else (\(x:xs) -> (toLower x):xs) (drop 15 f)} ''ResponseResult) + +-- | Response of Gremlin Server +data ResponseMessage = ResponseMessage { + _responseMessageRequestId :: Text + -- ^ The identifier of the RequestMessage that generated this ResponseMessage. + , _responseMessageStatus :: ResponseStatus + -- ^ status + , _responseMessageResult :: ResponseResult + -- ^ result +} deriving (Show) +$(deriveJSON defaultOptions{fieldLabelModifier = (\(x:xs) -> (toLower x):xs).(drop 16)} ''ResponseMessage) +makeFields ''ResponseMessage + +-- | Connection handle +data Connection = Connection { + _connectionSocket :: WS.Connection + , _connectionChans :: S.TVar (M.Map Text (S.TChan (Either String ResponseMessage))) +} +makeFields ''Connection + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,35 @@ +import Database.TinkerPop +import Database.TinkerPop.Types +import Test.Hspec +import Data.Aeson.QQ +import Control.Concurrent +import Control.Monad.Trans (liftIO) +import Control.Concurrent.MVar +import Control.Lens +import Data.Aeson.Lens + +main :: IO () +main = hspec $ do + describe "submit (test with gremlin-server-modern)" $ do + it "return result" $ do + run "localhost" 8182 $ \conn -> do + Right res <- submit conn "g.V().values('name')" Nothing + putStrLn $ show res + length res `shouldBe` 6 + it "with multi thread" $ do + run "localhost" 8182 $ \conn -> do + var <- newEmptyMVar + flip forkFinally (putMVar var) $ do + res <- submit conn "g.V().values('age')" Nothing + liftIO $ putStrLn $ show res + return res + Right res <- submit conn "g.V().has('name','marko').out('created').in('created').values('name')" Nothing + putStrLn $ show res + length res `shouldBe` 3 + Right (Right threadRes) <- takeMVar var + length threadRes `shouldBe` 4 + it "return error" $ do + run "localhost" 8182 $ \conn -> do + Left msg <- submit conn "throw new RuntimeException('MyError')" Nothing + msg `shouldBe` "MyError" +