diff --git a/hasbolt.cabal b/hasbolt.cabal --- a/hasbolt.cabal +++ b/hasbolt.cabal @@ -1,5 +1,5 @@ name: hasbolt -version: 0.1.0.4 +version: 0.1.0.5 cabal-version: >=1.10 build-type: Simple license: BSD3 @@ -23,7 +23,7 @@ . The code was tested with neo4j versions 3.0 and 3.1 category: Database -author: Pavel Yakovlev +author: Pavel Yakovlev, Martin Heuschober source-repository head type: git @@ -56,13 +56,14 @@ Database.Bolt.Connection.Pipe Database.Bolt.Connection Database.Bolt.Record + ghc-options: -Wall test-suite hasbolt-test type: exitcode-stdio-1.0 main-is: Spec.hs build-depends: base >=4.9.0.0 && <4.10, - hasbolt >=0.1.0.4 && <0.2, + hasbolt >=0.1.0.5 && <0.2, hspec >=2.2.4 && <2.3, QuickCheck >=2.8.2 && <2.9, hex >=0.1.2 && <0.2, diff --git a/src/Database/Bolt.hs b/src/Database/Bolt.hs --- a/src/Database/Bolt.hs +++ b/src/Database/Bolt.hs @@ -1,5 +1,5 @@ module Database.Bolt - ( BoltActionT (..) + ( BoltActionT , connect, close, reset , run, queryP, query, query_ , Pipe @@ -12,8 +12,8 @@ import Database.Bolt.Record import Database.Bolt.Connection.Pipe import Database.Bolt.Connection.Type -import Database.Bolt.Value.Instances -import Database.Bolt.Value.Structure +import Database.Bolt.Value.Instances () +import Database.Bolt.Value.Structure () import Database.Bolt.Value.Type import Data.Default (Default (..)) diff --git a/src/Database/Bolt/Connection.hs b/src/Database/Bolt/Connection.hs --- a/src/Database/Bolt/Connection.hs +++ b/src/Database/Bolt/Connection.hs @@ -3,21 +3,20 @@ import Database.Bolt.Connection.Pipe import Database.Bolt.Connection.Instances import Database.Bolt.Connection.Type -import Database.Bolt.Value.Instances import Database.Bolt.Value.Type import Database.Bolt.Record -import Control.Monad (void, when) +import Control.Monad (when) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Reader (ReaderT (..), ask, runReaderT) import Data.Text (Text) -import Data.Map.Strict (Map (..), empty) +import Data.Map.Strict (Map, empty) -- |Monad Transformer to do all BOLT actions in type BoltActionT = ReaderT Pipe -- |Runs BOLT action on selected pipe -run :: MonadIO m => Pipe -> BoltActionT m a -> m a +run :: Pipe -> BoltActionT m a -> m a run = flip runReaderT -- |Runs Cypher query with parameters and returns list of obtained 'Record's diff --git a/src/Database/Bolt/Connection/Instances.hs b/src/Database/Bolt/Connection/Instances.hs --- a/src/Database/Bolt/Connection/Instances.hs +++ b/src/Database/Bolt/Connection/Instances.hs @@ -1,4 +1,6 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Database.Bolt.Connection.Instances where @@ -6,30 +8,27 @@ import Database.Bolt.Value.Helpers import Database.Bolt.Value.Type -import Data.Map.Strict (Map (..), fromList, empty) +import Data.Map.Strict (Map, fromList, empty) import Data.Text (Text) -instance Structable Request where - toStructure (RequestInit agent token) = Structure sigInit [T agent, M $ tokenMap token] - toStructure (RequestRun stmt params) = Structure sigRun [T stmt, M params] +instance ToStructure Request where + toStructure (RequestInit{..}) = Structure sigInit [T agent, M $ tokenMap token] + toStructure (RequestRun{..}) = Structure sigRun [T statement, M parameters] toStructure RequestReset = Structure sigReset [] toStructure RequestAckFailure = Structure sigAFail [] toStructure RequestPullAll = Structure sigPAll [] toStructure RequestDiscardAll = Structure sigDAll [] - fromStructure = undefined - -instance Structable Response where - toStructure = undefined - - fromStructure (Structure sig fields) | sig == sigSucc = ResponseSuccess <$> extractMap (head fields) - | sig == sigRecs = return $ ResponseRecord (removeExtList fields) - | sig == sigIgn = ResponseIgnored <$> extractMap (head fields) - | sig == sigFail = ResponseFailure <$> extractMap (head fields) - | otherwise = fail "Not a Response value" +instance FromStructure Response where + fromStructure (Structure{..}) + | signature == sigSucc = ResponseSuccess <$> extractMap (head fields) + | signature == sigRecs = return $ ResponseRecord (removeExtList fields) + | signature == sigIgn = ResponseIgnored <$> extractMap (head fields) + | signature == sigFail = ResponseFailure <$> extractMap (head fields) + | otherwise = fail "Not a Response value" where removeExtList :: [Value] -> [Value] removeExtList [L x] = x - removeExtList _ = error "Record must contain only on value list" + removeExtList _ = error "Record must contain only a singleton list" -- Response check functions @@ -52,16 +51,15 @@ -- Helper functions createInit :: BoltCfg -> Request -createInit bcfg = RequestInit (userAgent bcfg) (tokenOf bcfg) +createInit BoltCfg{..} = RequestInit userAgent + AuthToken { scheme = "basic" + , principal = user + , credentials = password + } createRun :: Text -> Request createRun stmt = RequestRun stmt empty -tokenOf :: BoltCfg -> AuthToken -tokenOf bcfg = AuthToken { scheme = "basic" - , principal = user bcfg - , credentials = password bcfg - } tokenMap :: AuthToken -> Map Text Value tokenMap at = fromList [ ("scheme", T $ scheme at) diff --git a/src/Database/Bolt/Connection/Pipe.hs b/src/Database/Bolt/Connection/Pipe.hs --- a/src/Database/Bolt/Connection/Pipe.hs +++ b/src/Database/Bolt/Connection/Pipe.hs @@ -17,7 +17,6 @@ import Data.Word (Word16, Word32) import Network.Simple.TCP (closeSock, connectSock, recv, send) -import Network.Socket (isConnected) -- |Creates new 'Pipe' instance to use all requests through connect :: MonadIO m => BoltCfg -> m Pipe diff --git a/src/Database/Bolt/Connection/Type.hs b/src/Database/Bolt/Connection/Type.hs --- a/src/Database/Bolt/Connection/Type.hs +++ b/src/Database/Bolt/Connection/Type.hs @@ -5,7 +5,7 @@ import Database.Bolt.Value.Type import Data.Default (Default (..)) -import Data.Map.Strict (Map (..)) +import Data.Map.Strict (Map) import Data.Text (Text) import Data.Word (Word16, Word32) import Network.Simple.TCP (Socket) diff --git a/src/Database/Bolt/Record.hs b/src/Database/Bolt/Record.hs --- a/src/Database/Bolt/Record.hs +++ b/src/Database/Bolt/Record.hs @@ -3,12 +3,12 @@ module Database.Bolt.Record where -import Database.Bolt.Connection.Instances import Database.Bolt.Connection.Type -import Database.Bolt.Value.Structure +import Database.Bolt.Value.Structure () import Database.Bolt.Value.Type -import Data.Map.Strict (Map (..), fromList, (!), member) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe) import Data.Text (Text) @@ -43,6 +43,10 @@ exact (L l) = traverse exact l exact _ = fail "Not a List value" +instance RecordValue a => RecordValue (Maybe a) where + exact (N _) = return $ Nothing + exact x = Just <$> exact x + instance RecordValue (Map Text Value) where exact (M m) = return m exact _ = fail "Not a Map value" @@ -64,16 +68,13 @@ exact _ = fail "Not a Path value" at :: Monad m => Record -> Text -> m Value -at record key | member key record = return (record ! key) - | otherwise = fail "No such key in record" +at record key = case key `M.lookup` record of + Just result -> return result + Nothing -> fail "No such key in record" toRecords :: [Response] -> [Record] -toRecords (signature:rest) = if isSuccess signature then mkRecords rest - else [] - where keys :: [Text] - keys = fromMaybe [] $ exact (succMap signature ! "fields") - - mkRecords :: [Response] -> [Record] - mkRecords [terminal] = [] - mkRecords (x:xs) = fromList (zip keys (vals x)) : mkRecords xs - where vals (ResponseRecord xs) = xs +toRecords (ResponseSuccess response:rest) = + let keys :: [Text] + keys = fromMaybe [] $ exact =<< ("fields" `M.lookup` response) + in map (M.fromList . zip keys . recsList) $ init rest +toRecords _ = [] diff --git a/src/Database/Bolt/Value/Instances.hs b/src/Database/Bolt/Value/Instances.hs --- a/src/Database/Bolt/Value/Instances.hs +++ b/src/Database/Bolt/Value/Instances.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} module Database.Bolt.Value.Instances where @@ -9,16 +10,16 @@ import Control.Monad.Trans.State (gets, modify) import Data.Binary (Binary (..), decode, encode) import Data.Binary.IEEE754 (doubleToWord, wordToDouble) -import Data.ByteString (ByteString, append, cons, drop, - singleton, take) -import qualified Data.ByteString as B (concat, length) +import Data.ByteString (ByteString, append, cons, + singleton) +import qualified Data.ByteString as B import Data.ByteString.Lazy (fromStrict, toStrict) import Data.Int -import Data.Map.Strict (Map (..), assocs, size, fromList) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Data.Text (Text) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Word -import Prelude hiding (drop, take) instance BoltValue () where pack () = singleton nullCode @@ -41,7 +42,7 @@ | isIntX 8 int = cons int8Code $ encodeStrict (fromIntegral int :: Word8) | isIntX 16 int = cons int16Code $ encodeStrict (fromIntegral int :: Word16) | isIntX 32 int = cons int32Code $ encodeStrict (fromIntegral int :: Word32) - | isIntX 64 int = cons int64Code $ encodeStrict (fromIntegral int :: Word64) + | otherwise = cons int64Code $ encodeStrict (fromIntegral int :: Word64) unpackT = unpackW8 >>= unpackByMarker where unpackByMarker m | isTinyWord m = return . toInt $ (fromIntegral m :: Int8) @@ -68,8 +69,8 @@ | m == text16Code = toInt <$> unpackW16 >>= unpackTextBySize | m == text32Code = toInt <$> unpackW32 >>= unpackTextBySize | otherwise = fail "Not a Text value" - unpackTextBySize size = do str <- gets (take size) - modify (drop size) + unpackTextBySize size = do str <- gets (B.take size) + modify (B.drop size) return $ decodeUtf8 str instance BoltValue a => BoltValue [a] where @@ -85,8 +86,8 @@ unpackListBySize size = forM [1..size] $ const unpackT instance BoltValue a => BoltValue (Map Text a) where - pack dict = mkPackedCollection (size dict) pbs (dictConst, dict8Code, dict16Code, dict32Code) - where pbs = B.concat $ map mkPairPack $ assocs dict + pack dict = mkPackedCollection (M.size dict) pbs (dictConst, dict8Code, dict16Code, dict32Code) + where pbs = B.concat $ map mkPairPack $ M.assocs dict mkPairPack (key, val) = pack key `append` pack val unpackT = unpackW8 >>= unpackByMarker @@ -95,18 +96,18 @@ | m == dict16Code = toInt <$> unpackW16 >>= unpackDictBySize | m == dict32Code = toInt <$> unpackW32 >>= unpackDictBySize | otherwise = error "Not a Dict value" - unpackDictBySize = (fromList <$>) . unpackPairsBySize + unpackDictBySize = (M.fromList <$>) . unpackPairsBySize unpackPairsBySize size = forM [1..size] $ const $ do key <- unpackT value <- unpackT return (key, value) instance BoltValue Structure where - pack (Structure sig fields) | size < 16 = (structConst + fromIntegral size) `cons` pData - | size < 2^8 = struct8Code `cons` fromIntegral size `cons` pData - | size < 2^16 = struct16Code `cons` encodeStrict size `append` pData - where size = fromIntegral $ length fields :: Word16 - pData = sig `cons` B.concat (map pack fields) + pack (Structure sig lst) | size < size4 = (structConst + fromIntegral size) `cons` pData + | size < size8 = struct8Code `cons` fromIntegral size `cons` pData + | otherwise = struct16Code `cons` encodeStrict size `append` pData + where size = fromIntegral $ length lst :: Word16 + pData = sig `cons` B.concat (map pack lst) unpackT = unpackW8 >>= unpackByMarker where unpackByMarker m | isTinyStruct m = unpackStructureBySize (getSize m) @@ -114,8 +115,8 @@ | m == struct16Code = toInt <$> unpackW16 >>= unpackStructureBySize | otherwise = fail "Not a Structure value" unpackStructureBySize size = do sig <- unpackW8 - fields <- replicateM size unpackT - return $ Structure sig fields + lst <- replicateM size unpackT + return $ Structure sig lst instance BoltValue Value where pack (N n) = pack n @@ -139,7 +140,7 @@ | otherwise = fail "Not a Value value" -- |Structure unpack function -unpackS :: (Monad m, Structable a) => ByteString -> m a +unpackS :: (Monad m, FromStructure a) => ByteString -> m a unpackS bs = unpack bs >>= fromStructure -- = Integer values unpackers @@ -174,10 +175,10 @@ -- = Other helpers -- |Unpacks n bytes as a numeric type -observeNum :: (Monad m, Binary a, Num a) => Int -> UnpackT m a +observeNum :: (Monad m, Binary a) => Int -> UnpackT m a observeNum = (decodeStrict <$>) . topBS -unpackNum :: (Monad m, Binary a, Num a) => Int -> UnpackT m a +unpackNum :: (Monad m, Binary a) => Int -> UnpackT m a unpackNum = (decodeStrict <$>) . popBS decodeStrict :: Binary a => ByteString -> a @@ -188,19 +189,26 @@ -- |Obtain first n bytes of 'ByteString' topBS :: Monad m => Int -> UnpackT m ByteString -topBS size = gets (take size) +topBS size = gets (B.take size) -- |Obtain first n bytes of 'ByteString' and move offset by n popBS :: Monad m => Int -> UnpackT m ByteString popBS size = do top <- topBS size - modify (drop size) + modify (B.drop size) return top -- |Pack collection using it's size and set of BOLT constants mkPackedCollection :: Int -> ByteString -> (Word8, Word8, Word8, Word8) -> ByteString -mkPackedCollection size bst (wt, w8, w16, w32) = helper size - where helper size | size < 2^4 = cons (wt + fromIntegral size) bst - | size < 2^8 = cons w8 $ cons (fromIntegral size) bst - | size < 2^16 = cons w16 $ encodeStrict (fromIntegral size :: Word16) `append` bst - | size < 2^32 = cons w32 $ encodeStrict (fromIntegral size :: Word32) `append` bst - | otherwise = error "Cannot pack so large collection" +mkPackedCollection size bst (wt, w8, w16, w32) + | size < size4 = cons (wt + fromIntegral size) bst + | size < size8 = cons w8 $ cons (fromIntegral size) bst + | size < size16 = cons w16 $ encodeStrict (fromIntegral size :: Word16) `append` bst + | size < size32 = cons w32 $ encodeStrict (fromIntegral size :: Word32) `append` bst + | otherwise = error "Cannot pack so large collection" + +size4,size8, size16,size32 :: Integral a => a +size4 = 2^(4 :: Int) +size8 = 2^(8 :: Int) +size16 = 2^(16 :: Int) +size32 = 2^(32 :: Int) + diff --git a/src/Database/Bolt/Value/Structure.hs b/src/Database/Bolt/Value/Structure.hs --- a/src/Database/Bolt/Value/Structure.hs +++ b/src/Database/Bolt/Value/Structure.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Bolt.Value.Structure where import Database.Bolt.Value.Type @@ -5,9 +6,7 @@ import Data.Text (Text) -instance Structable Node where - toStructure = undefined - +instance FromStructure Node where fromStructure (Structure sig lst) | sig == sigNode = mkNode lst | otherwise = failNode where mkNode :: Monad m => [Value] -> m Node @@ -17,9 +16,7 @@ failNode :: Monad m => m Node failNode = fail "Not a Node value" -instance Structable Relationship where - toStructure = undefined - +instance FromStructure Relationship where fromStructure (Structure sig lst) | sig == sigRel = mkRel lst | otherwise = failRel where mkRel :: Monad m => [Value] -> m Relationship @@ -29,9 +26,7 @@ failRel :: Monad m => m Relationship failRel = fail "Not a Relationship value" -instance Structable URelationship where - toStructure = undefined - +instance FromStructure URelationship where fromStructure (Structure sig lst) | sig == sigURel = mkURel lst | otherwise = failURel where mkURel :: Monad m => [Value] -> m URelationship @@ -41,9 +36,7 @@ failURel :: Monad m => m URelationship failURel = fail "Not a Unbounded Relationship value" -instance Structable Path where - toStructure = undefined - +instance FromStructure Path where fromStructure (Structure sig lst) | sig == sigPath = mkPath lst | otherwise = failPath where mkPath :: Monad m => [Value] -> m Path diff --git a/src/Database/Bolt/Value/Type.hs b/src/Database/Bolt/Value/Type.hs --- a/src/Database/Bolt/Value/Type.hs +++ b/src/Database/Bolt/Value/Type.hs @@ -2,7 +2,7 @@ import Control.Monad.Trans.State (StateT (..), evalStateT) import Data.ByteString (ByteString) -import Data.Map.Strict (Map (..)) +import Data.Map.Strict (Map) import Data.Text (Text) import Data.Word (Word8) @@ -16,9 +16,11 @@ deriving (Show, Eq) -- |Generalizes all datatypes that can be serialized (deserialized) to (from) 'Structure's. -class Structable a where - toStructure :: a -> Structure +class FromStructure a where fromStructure :: Monad m => Structure -> m a + +class ToStructure a where + toStructure :: a -> Structure -- |The 'BoltValue' class describes values, that can be packed and unpacked for BOLT protocol. class BoltValue a where