gremlin-haskell (empty) → 0.1.0.0
raw patch · 8 files changed
+380/−0 lines, 8 filesdep +aesondep +aeson-qqdep +basesetup-changed
Dependencies added: aeson, aeson-qq, base, containers, gremlin-haskell, hspec, lens, lens-aeson, mtl, stm, text, unordered-containers, uuid, websockets
Files
- LICENSE +28/−0
- Setup.hs +2/−0
- examples/Main.hs +40/−0
- gremlin-haskell.cabal +73/−0
- src/Database/TinkerPop.hs +66/−0
- src/Database/TinkerPop/Internal.hs +40/−0
- src/Database/TinkerPop/Types.hs +96/−0
- test/Spec.hs +35/−0
+ LICENSE view
@@ -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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Main.hs view
@@ -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)
+ gremlin-haskell.cabal view
@@ -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
+ src/Database/TinkerPop.hs view
@@ -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
+ src/Database/TinkerPop/Internal.hs view
@@ -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)
+ src/Database/TinkerPop/Types.hs view
@@ -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+
+ test/Spec.hs view
@@ -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" +