hasbolt 0.1.0.4 → 0.1.0.5
raw patch · 10 files changed
+92/−91 lines, 10 filesdep ~hasboltPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: hasbolt
API changes (from Hackage documentation)
- Database.Bolt: run :: MonadIO m => Pipe -> BoltActionT m a -> m a
+ Database.Bolt: run :: Pipe -> BoltActionT m a -> m a
Files
- hasbolt.cabal +4/−3
- src/Database/Bolt.hs +3/−3
- src/Database/Bolt/Connection.hs +3/−4
- src/Database/Bolt/Connection/Instances.hs +19/−21
- src/Database/Bolt/Connection/Pipe.hs +0/−1
- src/Database/Bolt/Connection/Type.hs +1/−1
- src/Database/Bolt/Record.hs +15/−14
- src/Database/Bolt/Value/Instances.hs +37/−29
- src/Database/Bolt/Value/Structure.hs +5/−12
- src/Database/Bolt/Value/Type.hs +5/−3
hasbolt.cabal view
@@ -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,
src/Database/Bolt.hs view
@@ -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 (..))
src/Database/Bolt/Connection.hs view
@@ -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
src/Database/Bolt/Connection/Instances.hs view
@@ -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)
src/Database/Bolt/Connection/Pipe.hs view
@@ -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
src/Database/Bolt/Connection/Type.hs view
@@ -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)
src/Database/Bolt/Record.hs view
@@ -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 _ = []
src/Database/Bolt/Value/Instances.hs view
@@ -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)+
src/Database/Bolt/Value/Structure.hs view
@@ -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
src/Database/Bolt/Value/Type.hs view
@@ -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