hasbolt 0.1.3.6 → 0.1.4.0

raw patch · 16 files changed

+349/−230 lines, 16 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• hasbolt.cabal +1/−2
• src/Database/Bolt.hs +3/−3
• src/Database/Bolt/Connection.hs +58/−39
• src/Database/Bolt/Connection/Connection.hs +1/−1
• src/Database/Bolt/Connection/Instances.hs +8/−6
• src/Database/Bolt/Connection/Pipe.hs +43/−21
• src/Database/Bolt/Connection/Type.hs +58/−3
• src/Database/Bolt/Lazy.hs +3/−2
• src/Database/Bolt/Lens.hs +1/−1
• src/Database/Bolt/Record.hs +44/−42
• src/Database/Bolt/Serialization.hs +2/−0
• src/Database/Bolt/Transaction.hs +1/−1
• src/Database/Bolt/Value/Instances.hs +56/−15
• src/Database/Bolt/Value/Structure.hs +0/−69
• src/Database/Bolt/Value/Type.hs +54/−9
• test/Spec.hs +16/−16

@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: hasbolt-version: 0.1.3.6+version: 0.1.4.0 license: BSD3 license-file: LICENSE copyright: (c) 2018 Pavel Yakovlev@@ -42,7 +42,6 @@         Database.Bolt.Value.Type         Database.Bolt.Value.Helpers         Database.Bolt.Value.Instances-        Database.Bolt.Value.Structure         Database.Bolt.Connection.Connection         Database.Bolt.Connection.Type         Database.Bolt.Connection.Instances

@@ -1,12 +1,13 @@ module Database.Bolt     ( BoltActionT+    , BoltError (..), UnpackError (..)     , connect, close, reset-    , run, queryP, query, queryP_, query_+    , run, runE, queryP, query, queryP_, query_     , transact     , (=:), props     , Pipe     , BoltCfg (..)-    , Value (..), IsValue (..), Structure (..), Record, RecordValue (..), at+    , Value (..), IsValue (..), Structure (..), Record, RecordValue (..), exact, exactMaybe, at     , Node (..), Relationship (..), URelationship (..), Path (..)     ) where @@ -16,7 +17,6 @@ import           Database.Bolt.Record import           Database.Bolt.Transaction import           Database.Bolt.Value.Instances ()-import           Database.Bolt.Value.Structure () import           Database.Bolt.Value.Type  import           Data.Text                     (Text)

@@ -1,6 +1,12 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+ module Database.Bolt.Connection   ( BoltActionT-  , run+  , BoltError (..)+  , UnpackError (..)+  , at+  , run, runE   , queryP, query   , queryP', query'   , queryP_, query_@@ -12,21 +18,27 @@ import           Database.Bolt.Value.Type import           Database.Bolt.Record +import           Control.Exception             (throwIO) import           Control.Monad                 (void)-import           Control.Monad.IO.Class        (MonadIO (..), liftIO)-import           Control.Monad.Reader          (ReaderT (..), ask, runReaderT)+import           Control.Monad.Trans           (MonadIO (..))+import           Control.Monad.Reader          (MonadReader (..), runReaderT)+import           Control.Monad.Except          (MonadError (..), runExceptT) import           Data.Text                     (Text)-import           Data.Map.Strict               (Map, empty)+import           Data.Map.Strict               (Map, empty, fromList)  import           System.IO.Unsafe              (unsafeInterleaveIO) --- |Monad Transformer to do all BOLT actions in-type BoltActionT = ReaderT Pipe- -- |Runs BOLT action on selected pipe-run :: Pipe -> BoltActionT m a -> m a-run = flip runReaderT+runE :: MonadIO m => Pipe -> BoltActionT m a -> m (Either BoltError a)+runE pipe action = runExceptT (runReaderT (runBoltActionT action) pipe)  +-- |Runs BOLT action on selected pipe (with errors throw)+run :: MonadIO m => Pipe -> BoltActionT m a -> m a+run pipe action = do result <- runE pipe action+                     case result of+                       Right x -> pure x+                       Left r  -> liftIO $ throwIO r+ -- |Runs Cypher query with parameters and returns list of obtained 'Record's. Lazy version queryP :: MonadIO m => Text -> Map Text Value -> BoltActionT m [Record] queryP = querySL False@@ -45,11 +57,9 @@  -- |Runs Cypher query with parameters and ignores response queryP_ :: MonadIO m => Text -> Map Text Value -> BoltActionT m ()-queryP_ cypher params = do pipe <- ask-                           liftIO $ do-                             void $ sendRequest pipe cypher params-                             discardAll pipe-     +queryP_ cypher params = do void $ sendRequest cypher params+                           ask >>= liftE . discardAll+ -- |Runs Cypher query and ignores response query_ :: MonadIO m => Text -> BoltActionT m () query_ cypher = queryP_ cypher empty@@ -57,38 +67,47 @@ -- Helper functions  querySL :: MonadIO m => Bool -> Text -> Map Text Value -> BoltActionT m [Record]-querySL strict cypher params = do pipe <- ask-                                  liftIO $ do-                                    keys <- pullKeys pipe cypher params-                                    pullRecords strict pipe keys+querySL strict cypher params = do keys <- pullKeys cypher params+                                  pullRecords strict keys -pullKeys :: Pipe -> Text -> Map Text Value -> IO [Text]-pullKeys pipe cypher params = do status <- sendRequest pipe cypher params-                                 flush pipe RequestPullAll-                                 mkKeys status+pullKeys :: MonadIO m => Text -> Map Text Value -> BoltActionT m [Text]+pullKeys cypher params = do pipe <- ask+                            status <- sendRequest cypher params+                            liftE $ flush pipe RequestPullAll+                            mkKeys status+  where+    mkKeys :: MonadIO m => Response -> BoltActionT m [Text]+    mkKeys (ResponseSuccess response) = response `at` "fields" `catchError` \(RecordHasNoKey _) -> pure []+    mkKeys x                          = throwError $ ResponseError (mkFailure x) -pullRecords :: Bool -> Pipe -> [Text] -> IO [Record]-pullRecords strict pipe keys = fetch pipe >>= cases+pullRecords :: MonadIO m => Bool -> [Text] -> BoltActionT m [Record]+pullRecords strict keys = do pipe <- ask+                             resp <- liftE $ fetch pipe+                             cases resp   where-    cases :: Response -> IO [Record]+    cases :: MonadIO m => Response -> BoltActionT m [Record]     cases resp | isSuccess resp = pure []-               | isFailure resp = ackFailure pipe >> mkFailure resp+               | isFailure resp = do ask >>= ackFailure+                                     throwError $ ResponseError (mkFailure resp)                | otherwise      = parseRecord resp -    parseRecord :: Response -> IO [Record]+    parseRecord :: MonadIO m => Response -> BoltActionT m [Record]     parseRecord resp = do-        let record = mkRecord keys resp-        let pull = pullRecords strict pipe keys-        rest <- if strict then pull-                          else unsafeInterleaveIO pull+        pipe <- ask+        let record = fromList . zip keys $ recsList resp+        let pull = run pipe (pullRecords strict keys)+        rest <- liftIO $ if strict then pull+                                   else unsafeInterleaveIO pull         pure (record:rest)  -- |Sends request to database and makes an action-sendRequest :: Pipe -> Text -> Map Text Value -> IO Response-sendRequest pipe cypher params =-  do flush pipe $ RequestRun cypher params-     status <- fetch pipe-     if isSuccess status-       then pure status-       else do ackFailure pipe-               mkFailure status+sendRequest :: MonadIO m => Text -> Map Text Value -> BoltActionT m Response+sendRequest cypher params =+  do pipe <- ask+     liftE $ do+         flush pipe $ RequestRun cypher params+         status <- fetch pipe+         if isSuccess status+           then pure status+           else do ackFailure pipe+                   throwError $ ResponseError (mkFailure status)

@@ -2,7 +2,7 @@  import           Control.Applicative    (pure, (<$>)) import           Control.Monad          (when, forM_)-import           Control.Monad.IO.Class (MonadIO (..))+import           Control.Monad.Trans    (MonadIO (..)) import           Data.ByteString        (ByteString, null) import           Data.Default           (Default (..)) import           Network.Socket         (PortNumber)

@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-}  module Database.Bolt.Connection.Instances where@@ -8,6 +9,7 @@ import           Database.Bolt.Value.Helpers import           Database.Bolt.Value.Type +import           Control.Monad.Except           (MonadError (..)) import           Data.Map.Strict                (Map, fromList, empty, (!)) import           Data.Text                      (Text) @@ -25,7 +27,7 @@     | signature == sigRecs = pure $ ResponseRecord (removeExtList fields)     | signature == sigIgn  = ResponseIgnored <$> extractMap (head fields)     | signature == sigFail = ResponseFailure <$> extractMap (head fields)-    | otherwise            = fail "Not a Response value"+    | otherwise            = throwError $ Not "Response"      where removeExtList :: [Value] -> [Value]           removeExtList [L x] = x           removeExtList _     = error "Record must contain only a singleton list"@@ -67,13 +69,13 @@                        , ("credentials", T $ credentials at)                        ] -extractMap :: Monad m => Value -> m (Map Text Value)+extractMap :: MonadError UnpackError m => Value -> m (Map Text Value) extractMap (M mp) = pure mp-extractMap _      = fail "Not a Dict value"+extractMap _      = throwError NotDict -mkFailure :: Monad m => Response -> m a+mkFailure :: Response -> ResponseError mkFailure ResponseFailure{..} =   let (T code) = failMap ! "code"       (T msg)  = failMap ! "message"-  in fail $ "code: " ++ show code ++ ", message: " ++ show msg-mkFailure _ = fail "Unknown error"+  in  KnownResponseFailure code msg+mkFailure _ = UnknownResponseFailure

@@ -1,3 +1,5 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} module Database.Bolt.Connection.Pipe where  import           Database.Bolt.Connection.Instances@@ -7,20 +9,27 @@ import qualified Database.Bolt.Connection.Connection as C (close, connect, recv,                                                            send, sendMany) +import           Control.Exception                   (throwIO) import           Control.Monad                       (forM_, unless, void, when)-import           Control.Monad.IO.Class              (MonadIO (..))+import           Control.Monad.Except                (MonadError (..), ExceptT, runExceptT)+import           Control.Monad.Trans                 (MonadIO (..)) import           Data.ByteString                     (ByteString) import qualified Data.ByteString                     as B (concat, length, null,                                                            splitAt) import           Data.Word                           (Word16) import           Network.Connection                  (Connection) +type MonadPipe m = (MonadIO m, MonadError BoltError m)+ -- |Creates new 'Pipe' instance to use all requests through connect :: MonadIO m => BoltCfg -> m Pipe-connect bcfg = do conn <- C.connect (secure bcfg) (host bcfg) (fromIntegral $ port bcfg)-                  let pipe = Pipe conn (maxChunkSize bcfg)-                  handshake pipe bcfg-                  pure pipe+connect = makeIO connect'+  where+    connect' :: MonadPipe m => BoltCfg -> m Pipe+    connect' bcfg = do conn <- C.connect (secure bcfg) (host bcfg) (fromIntegral $ port bcfg)+                       let pipe = Pipe conn (maxChunkSize bcfg)+                       handshake pipe bcfg+                       pure pipe  -- |Closes 'Pipe' close :: MonadIO m => Pipe -> m ()@@ -28,18 +37,30 @@  -- |Resets current sessions reset :: MonadIO m => Pipe -> m ()-reset pipe = do flush pipe RequestReset-                response <- fetch pipe-                when (isFailure response) $-                  fail "Reset failed"+reset = makeIO reset'+  where+    reset' :: MonadPipe m => Pipe -> m ()+    reset' pipe = do flush pipe RequestReset+                     response <- fetch pipe+                     when (isFailure response) $+                       throwError ResetFailed -ackFailure :: MonadIO m => Pipe -> m ()+-- Helper to make pipe operations in IO+makeIO :: MonadIO m => (a -> ExceptT BoltError m b) -> a -> m b+makeIO action arg = do actionIO <- runExceptT (action arg)+                       case actionIO of+                         Right x -> pure x+                         Left  e -> liftIO $ throwIO e++-- = Internal interfaces++ackFailure :: MonadPipe m => Pipe -> m () ackFailure pipe = flush pipe RequestAckFailure >> void (fetch pipe) -discardAll :: MonadIO m => Pipe -> m ()+discardAll :: MonadPipe m => Pipe -> m () discardAll pipe = flush pipe RequestDiscardAll >> void (fetch pipe) -flush :: MonadIO m => Pipe -> Request -> m ()+flush :: MonadPipe m => Pipe -> Request -> m () flush pipe request = do forM_ chunks $ C.sendMany conn . mkChunk                         C.send conn terminal   where bs        = pack $ toStructure request@@ -52,12 +73,13 @@         mkChunk chunk = let size = fromIntegral (B.length chunk) :: Word16                         in  [encodeStrict size, chunk] -fetch :: MonadIO m => Pipe -> m Response+fetch :: MonadPipe m => Pipe -> m Response fetch pipe = do bs <- B.concat <$> chunks-                unpack bs >>= fromStructure+                response <- flip unpackAction bs $ unpackT >>= fromStructure+                either (throwError . WrongMessageFormat) pure response   where conn = connection pipe -        chunks :: MonadIO m => m [ByteString]+        chunks :: MonadPipe m => m [ByteString]         chunks = do size <- decodeStrict <$> recvChunk conn 2                     chunk <- recvChunk conn size                     if B.null chunk@@ -67,29 +89,29 @@  -- Helper functions -handshake :: MonadIO m => Pipe -> BoltCfg -> m ()+handshake :: MonadPipe m => Pipe -> BoltCfg -> m () handshake pipe bcfg = do let conn = connection pipe                          C.send conn (encodeStrict $ magic bcfg)                          C.send conn (boltVersionProposal bcfg)                          serverVersion <- decodeStrict <$> recvChunk conn 4                          when (serverVersion /= version bcfg) $-                           fail "Unsupported server version"+                           throwError UnsupportedServerVersion                          flush pipe (createInit bcfg)                          response <- fetch pipe                          unless (isSuccess response) $-                           fail "Authentification failed"+                           throwError AuthentificationFailed  boltVersionProposal :: BoltCfg -> ByteString boltVersionProposal bcfg = B.concat $ encodeStrict <$> [version bcfg, 0, 0, 0] -recvChunk :: MonadIO m => Connection -> Word16 -> m ByteString+recvChunk :: MonadPipe m => Connection -> Word16 -> m ByteString recvChunk conn size = B.concat <$> helper (fromIntegral size)-  where helper :: MonadIO m => Int -> m [ByteString]+  where helper :: MonadPipe m => Int -> m [ByteString]         helper 0  = pure []         helper sz = do mbChunk <- C.recv conn sz                        case mbChunk of                          Just chunk -> (chunk:) <$> helper (sz - B.length chunk)-                         Nothing    -> fail "Cannot read chunk from sock"+                         Nothing    -> throwError CannotReadChunk  chunkSizeFor :: Word16 -> ByteString -> Int chunkSizeFor maxSize bs = 1 + div len noc

@@ -1,15 +1,70 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Database.Bolt.Connection.Type where -import           Database.Bolt.Value.Type+import           Database.Bolt.Value.Type hiding (unpack) +import           Control.Exception               (Exception (..), SomeException, handle)+import           Control.Monad.Trans             (MonadTrans (..), MonadIO (..))+import           Control.Monad.Reader            (MonadReader (..), ReaderT)+import           Control.Monad.Except            (MonadError (..), ExceptT (..))+ import           Data.Default                    (Default (..))+import           Data.Monoid                     ((<>)) import           Data.Map.Strict                 (Map)-import           Data.Text                       (Text)+import           Data.Text                       (Text, unpack) import           Data.Word                       (Word16, Word32) import           Network.Connection              (Connection) ++-- |Error obtained from BOLT server+data ResponseError = KnownResponseFailure Text Text+                   | UnknownResponseFailure+  deriving (Eq, Ord)++instance Show ResponseError where+  show (KnownResponseFailure tpe msg) = unpack tpe <> ": " <> unpack msg+  show UnknownResponseFailure         = "Unknown response error"++-- |Error that can appear during 'BoltActionT' manipulations+data BoltError = UnsupportedServerVersion+               | AuthentificationFailed+               | ResetFailed+               | CannotReadChunk+               | WrongMessageFormat UnpackError+               | NoStructureInResponse+               | ResponseError ResponseError+               | RecordHasNoKey Text+               | NonHasboltError SomeException++instance Show BoltError where+  show UnsupportedServerVersion = "Cannot connect: unsupported server version"+  show AuthentificationFailed   = "Cannot connect: authentification failed"+  show ResetFailed              = "Cannot reset current pipe: recieved failure from server"+  show CannotReadChunk          = "Cannot fetch: chunk read failed"+  show (WrongMessageFormat msg) = "Cannot fetch: wrong message format (" <> show msg <> ")"+  show NoStructureInResponse    = "Cannot fetch: no structure in response"+  show (ResponseError re)       = show re+  show (RecordHasNoKey key)     = "Cannot unpack record: key '" <> unpack key <> "' is not presented"+  show (NonHasboltError msg)    = "User error: " <> show msg++instance Exception BoltError++-- |Monad Transformer to do all BOLT actions in+newtype BoltActionT m a = BoltActionT { runBoltActionT :: ReaderT Pipe (ExceptT BoltError m) a }+  deriving (Functor, Applicative, Monad, MonadError BoltError, MonadReader Pipe)++instance MonadTrans BoltActionT where+  lift = BoltActionT . lift . lift++instance MonadIO m => MonadIO (BoltActionT m) where+  liftIO = BoltActionT . lift . ExceptT . liftIO . handle (pure . Left . NonHasboltError) . fmap Right++liftE :: Monad m => ExceptT BoltError m a -> BoltActionT m a+liftE = BoltActionT . lift+ -- |Configuration of driver connection data BoltCfg = BoltCfg { magic         :: Word32  -- ^'6060B017' value                        , version       :: Word32  -- ^'00000001' value@@ -26,7 +81,7 @@ instance Default BoltCfg where   def = BoltCfg { magic         = 1616949271                 , version       = 1-                , userAgent     = "hasbolt/1.3"+                , userAgent     = "hasbolt/1.4"                 , maxChunkSize  = 65535                 , socketTimeout = 5                 , host          = "127.0.0.1"

@@ -1,12 +1,13 @@ module Database.Bolt.Lazy     ( BoltActionT+    , BoltError (..), UnpackError (..)     , connect, close, reset-    , run, queryP, query, queryP_, query_+    , run, runE, queryP, query, queryP_, query_     , transact     , (=:), props     , Pipe     , BoltCfg (..)-    , Value (..), IsValue (..), Structure (..), Record, RecordValue (..), at+    , Value (..), IsValue (..), Structure (..), Record, RecordValue (..), exact, exactMaybe, at     , Node (..), Relationship (..), URelationship (..), Path (..)     ) where 

@@ -22,7 +22,7 @@ -- | This 'Fold' extracts value of required type from 'B.Value'. If 'B.Value' contains wrong -- type, 'exact' is an empty 'Fold'. exact :: B.RecordValue a => Fold B.Value a-exact = to B.exact . _Just+exact = to B.exactMaybe . _Just  -- | Extract field by given key from 'B.Record'. If there is no such key or the type is wrong, -- this is an empty 'Fold'.

@@ -1,16 +1,16 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}  module Database.Bolt.Record where -import           Database.Bolt.Connection.Type-import           Database.Bolt.Connection.Instances-import           Database.Bolt.Value.Structure () import           Database.Bolt.Value.Type+import           Database.Bolt.Value.Instances      ()+import           Database.Bolt.Connection.Type +import           Control.Monad.Except               (MonadError (..), withExceptT) import           Data.Map.Strict                    (Map)-import qualified Data.Map.Strict                    as M-import           Data.Maybe                         (fromMaybe)+import qualified Data.Map.Strict               as M (lookup) import           Data.Text                          (Text)  -- |Result type for query requests@@ -18,65 +18,67 @@  -- |Get exact type from Value class RecordValue a where-  exact :: Monad m => Value -> m a+  exactEither :: Value -> Either UnpackError a +exact :: (MonadError UnpackError m, RecordValue a) => Value -> m a+exact = either throwError pure . exactEither++exactMaybe :: RecordValue a => Value -> Maybe a+exactMaybe = either (const Nothing) Just . exactEither+ instance RecordValue () where-  exact (N _) = pure ()-  exact x     = fail $ show x ++ " is not a Null value"+  exactEither (N _) = pure ()+  exactEither _     = throwError NotNull   instance RecordValue Bool where-  exact (B b) = pure b-  exact x     = fail $ show x ++ " is not a Bool value"+  exactEither (B b) = pure b+  exactEither _     = throwError NotBool  instance RecordValue Int where-  exact (I i) = pure i-  exact x     = fail $ show x ++ " is not an Int value"+  exactEither (I i) = pure i+  exactEither _     = throwError NotInt  instance RecordValue Double where-  exact (F d) = pure d-  exact x     = fail $ show x ++ " is not a Double value"+  exactEither (F d) = pure d+  exactEither _     = throwError NotFloat  instance RecordValue Text where-  exact (T t) = pure t-  exact x     = fail $ show x ++ " is not a Text value"+  exactEither (T t) = pure t+  exactEither _     = throwError NotString +instance RecordValue Value where+  exactEither = pure+ instance RecordValue a => RecordValue [a] where-  exact (L l) = traverse exact l-  exact x     = fail $ show x ++ " is not a List value"+  exactEither (L l) = traverse exactEither l+  exactEither _     = throwError NotList   instance RecordValue a => RecordValue (Maybe a) where-  exact (N _) = pure Nothing-  exact x     = Just <$> exact x+  exactEither (N _) = pure Nothing+  exactEither x     = Just <$> exactEither x  instance RecordValue (Map Text Value) where-  exact (M m) = pure m-  exact x     = fail $ show x ++ " is not a Map value"+  exactEither (M m) = pure m+  exactEither _     = throwError NotDict  instance RecordValue Node where-  exact (S s) = fromStructure s-  exact x     = fail $ show x ++ " is not a Node value"+  exactEither (S s) = fromStructure s+  exactEither _     = throwError $ Not "Node"   instance RecordValue Relationship where-  exact (S s) = fromStructure s-  exact x     = fail $ show x ++ " is not a Relationship value"+  exactEither (S s) = fromStructure s+  exactEither _     = throwError $ Not "Relationship"  instance RecordValue URelationship where-  exact (S s) = fromStructure s-  exact x     = fail $ show x ++ " is not a URelationship value"+  exactEither (S s) = fromStructure s+  exactEither _     = throwError $ Not "URelationship"   instance RecordValue Path where-  exact (S s) = fromStructure s-  exact x     = fail $ show x ++ " is not a Path value"--at :: Monad m => Record -> Text -> m Value-at record key = case key `M.lookup` record of-                  Just result -> pure result-                  Nothing     -> fail $ "No such key (" ++ show key ++ ") in record"--mkKeys :: Monad m => Response -> m [Text]-mkKeys (ResponseSuccess response) = let mbKeys = exact =<< ("fields" `M.lookup` response)-                                    in pure $ fromMaybe [] mbKeys-mkKeys x = mkFailure x+  exactEither (S s) = fromStructure s+  exactEither _     = throwError $ Not "Path" -mkRecord :: [Text] -> Response -> Record-mkRecord keys = M.fromList . zip keys . recsList+-- |Gets result from obtained record+at :: (Monad m, RecordValue a) => Record -> Text -> BoltActionT m a+at record key = case M.lookup key record of+                  Just x  -> liftE $ withExceptT WrongMessageFormat (exact x)+                  Nothing -> throwError $ RecordHasNoKey key

@@ -1,7 +1,9 @@ module Database.Bolt.Serialization   ( BoltValue (..)   , UnpackT+  , UnpackError (..)   , ToStructure (..), FromStructure (..)+  , unpack, unpackF, unpackAction   ) where  import Database.Bolt.Value.Type

@@ -13,7 +13,7 @@  -- |Runs a sequence of actions as transaction. All queries would be rolled back -- in case of any exception inside the block.-transact :: (MonadError e m, MonadIO m) => BoltActionT m a -> BoltActionT m a+transact :: MonadIO m => BoltActionT m a -> BoltActionT m a transact actions = do     txBegin     let processErrors = flip catchError $ \e -> txRollback >> throwError e

@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}  module Database.Bolt.Value.Instances where @@ -10,6 +11,7 @@ import           Control.Applicative          (pure) import           Control.Monad                (forM, replicateM) import           Control.Monad.State          (gets, modify)+import           Control.Monad.Except         (MonadError (..)) import           Data.Binary                  (Binary (..), decode, encode) import           Data.Binary.IEEE754          (doubleToWord, wordToDouble) import           Data.ByteString              (ByteString, append, cons,@@ -28,7 +30,7 @@    unpackT = unpackW8 >>= unpackByMarker     where unpackByMarker m | m == nullCode = pure ()-                           | otherwise     = fail "Not a Null value"+                           | otherwise     = throwError NotNull  instance BoltValue Bool where   pack True  = singleton trueCode@@ -37,7 +39,7 @@   unpackT = unpackW8 >>= unpackByMarker     where unpackByMarker m | m == trueCode  = pure True                            | m == falseCode = pure False-                           | otherwise      = fail "Not a Bool value"+                           | otherwise      = throwError NotBool  instance BoltValue Int where   pack int | isTinyInt int = encodeStrict (fromIntegral int :: Word8)@@ -53,14 +55,14 @@                            | m == int16Code = toInt <$> unpackI16                            | m == int32Code = toInt <$> unpackI32                            | m == int64Code = toInt <$> unpackI64-                           | otherwise      = fail "Not an Int value"+                           | otherwise      = throwError NotInt  instance BoltValue Double where   pack dbl = cons doubleCode $ encodeStrict (doubleToWord dbl)    unpackT = unpackW8 >>= unpackByMarker     where unpackByMarker m | m == doubleCode = wordToDouble <$> unpackW64-                           | otherwise       = fail "Not a Double value"+                           | otherwise       = throwError NotFloat  instance BoltValue Text where   pack txt = mkPackedCollection (B.length pbs) pbs (textConst, text8Code, text16Code, text32Code)@@ -71,7 +73,7 @@                            | m == text8Code  = toInt <$> unpackW8 >>= unpackTextBySize                            | m == text16Code = toInt <$> unpackW16 >>= unpackTextBySize                            | m == text32Code = toInt <$> unpackW32 >>= unpackTextBySize-                           | otherwise       = fail "Not a Text value"+                           | otherwise       = throwError NotString           unpackTextBySize size = do str <- gets (B.take size)                                      modify (B.drop size)                                      pure $ decodeUtf8 str@@ -85,7 +87,7 @@                            | m == list8Code  = toInt <$> unpackW8 >>= unpackListBySize                            | m == list16Code = toInt <$> unpackW16 >>= unpackListBySize                            | m == list32Code = toInt <$> unpackW32 >>= unpackListBySize-                           | otherwise       = fail "Not a List value"+                           | otherwise       = throwError NotList           unpackListBySize size = forM [1..size] $ const unpackT  instance BoltValue a => BoltValue (Map Text a) where@@ -98,7 +100,7 @@                            | m == dict8Code  = toInt <$> unpackW8 >>= unpackDictBySize                            | m == dict16Code = toInt <$> unpackW16 >>= unpackDictBySize                            | m == dict32Code = toInt <$> unpackW32 >>= unpackDictBySize-                           | otherwise       = error "Not a Dict value"+                           | otherwise       = throwError NotDict            unpackDictBySize = (M.fromList <$>) . unpackPairsBySize           unpackPairsBySize size = forM [1..size] $ const $ do                                      key <- unpackT@@ -107,9 +109,9 @@  instance BoltValue Structure where   pack (Structure sig lst) | size < size4  = (structConst + fromIntegral size) `cons` pData-                             | size < size8  = struct8Code `cons` fromIntegral size `cons` pData-                             | size < size16 = struct16Code `cons` encodeStrict size `append` pData-                             | otherwise     = error "Cannot pack so large structure"+                           | size < size8  = struct8Code `cons` fromIntegral size `cons` pData+                           | size < size16 = struct16Code `cons` encodeStrict size `append` pData+                           | otherwise     = error "Cannot pack so large structure"     where size = fromIntegral $ length lst :: Word16           pData = sig `cons` B.concat (map pack lst) @@ -117,7 +119,7 @@     where unpackByMarker m | isTinyStruct m    = unpackStructureBySize (getSize m)                            | m == struct8Code  = toInt <$> unpackW8 >>= unpackStructureBySize                            | m == struct16Code = toInt <$> unpackW16 >>= unpackStructureBySize-                           | otherwise         = fail "Not a Structure value"+                           | otherwise         = throwError NotStructure           unpackStructureBySize size = Structure <$> unpackW8 <*> replicateM size unpackT  instance BoltValue Value where@@ -139,11 +141,50 @@                            | isList   m = L <$> unpackT                            | isDict   m = M <$> unpackT                            | isStruct m = S <$> unpackT-                           | otherwise  = fail "Not a Value value"+                           | otherwise  = throwError NotValue  --- |Structure unpack function-unpackS :: (Monad m, FromStructure a) => ByteString -> m a-unpackS bs = unpack bs >>= fromStructure+-- = Structure instances for Neo4j structures++instance FromStructure Node where+  fromStructure struct =+    case struct of+      (Structure sig [I nid, L vlbls, M prps]) | sig == sigNode -> flip (Node nid) prps <$> cnvT vlbls+      _                                                         -> throwError $ Not "Node"+    where+      cnvT []       = pure []+      cnvT (T x:xs) = (x:) <$> cnvT xs+      cnvT _        = throwError NotString ++instance FromStructure Relationship where+  fromStructure struct =+    case struct of+      (Structure sig [I rid, I sni, I eni, T rt, M rp]) | sig == sigRel -> pure $ Relationship rid sni eni rt rp+      _                                                                 -> throwError $ Not "Relationship"++instance FromStructure URelationship where+  fromStructure struct =+    case struct of+      (Structure sig [I rid, T rt, M rp]) | sig == sigURel -> pure $ URelationship rid rt rp+      _                                                    -> throwError $ Not "URelationship"++instance FromStructure Path where+  fromStructure struct = +    case struct of+      (Structure sig [L vnp, L vrp, L vip]) | sig == sigPath -> Path <$> cnvN vnp <*> cnvR vrp <*> cnvI vip+      _                                                      -> throwError $ Not "Path"+    where+      cnvN []       = pure []+      cnvN (S x:xs) = (:) <$> fromStructure x <*> cnvN xs+      cnvN _        = throwError $ Not "Node"+      +      cnvR []       = pure []+      cnvR (S x:xs) = (:) <$> fromStructure x <*> cnvR xs+      cnvR _        = throwError NotStructure  +      +      cnvI []       = pure []+      cnvI (I x:xs) = (x:) <$> cnvI xs+      cnvI _        = throwError NotInt+  -- = Integer values unpackers 

@@ -1,69 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Database.Bolt.Value.Structure where--import Database.Bolt.Value.Type-import Database.Bolt.Value.Helpers--import Data.Text (Text)--instance FromStructure Node where-  fromStructure (Structure sig lst) | sig == sigNode = mkNode lst-                                    | otherwise      = failNode-    where mkNode :: Monad m => [Value] -> m Node-          mkNode [I nid, L vlbls, M prps] = flip (Node nid) prps <$> cnvT vlbls-          mkNode _                        = failNode--          failNode :: Monad m => m Node-          failNode = fail $ show lst ++ " is not a Node value"--instance FromStructure Relationship where-  fromStructure (Structure sig lst) | sig == sigRel = mkRel lst-                                    | otherwise     = failRel-    where mkRel :: Monad m => [Value] -> m Relationship-          mkRel [I rid, I sni, I eni, T rt, M rp] = pure $ Relationship rid sni eni rt rp-          mkRel _                                 = failRel--          failRel :: Monad m => m Relationship-          failRel = fail $ show lst ++ " is not a Relationship value"--instance FromStructure URelationship where-  fromStructure (Structure sig lst) | sig == sigURel = mkURel lst-                                    | otherwise      = failURel-    where mkURel :: Monad m => [Value] -> m URelationship-          mkURel [I rid, T rt, M rp] = pure $ URelationship rid rt rp-          mkURel _                   = failURel--          failURel :: Monad m => m URelationship-          failURel = fail $ show lst ++ " is not an Unbounded Relationship value"--instance FromStructure Path where-  fromStructure (Structure sig lst) | sig == sigPath = mkPath lst-                                    | otherwise      = failPath-    where mkPath :: Monad m => [Value] -> m Path-          mkPath [L vnp, L vrp, L vip] = Path <$> cnvN vnp <*> cnvR vrp <*> cnvI vip-          mkPath _                     = failPath--          failPath :: Monad m => m Path-          failPath = fail $ show lst ++ " is not a Path value"---- = Helper functions--cnvT :: Monad m => [Value] -> m [Text]-cnvT []       = pure []-cnvT (T x:xs) = (x:) <$> cnvT xs-cnvT (x:_)    = fail $ "Non-text value (" ++ show x ++ ") in text list"--cnvN :: Monad m => [Value] -> m [Node]-cnvN []       = pure []-cnvN (S x:xs) = (:) <$> fromStructure x <*> cnvN xs-cnvN (x:_)    = fail $ "Non-node value (" ++ show x ++ ") in node list"--cnvR :: Monad m => [Value] -> m [URelationship]-cnvR []       = pure []-cnvR (S x:xs) = (:) <$> fromStructure x <*> cnvR xs-cnvR (x:_)    = fail $ "Non-(u)relationship value (" ++ show x ++ ") in (u)relationship list"--cnvI :: Monad m => [Value] -> m [Int]-cnvI []       = pure []-cnvI (I x:xs) = (x:) <$> cnvI xs-cnvI (x:_)    = fail $ "Non-int value (" ++ show x ++ ") in int list"

@@ -1,14 +1,47 @@-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Database.Bolt.Value.Type where -import           Control.Monad.State       (StateT (..), evalStateT)+import           Control.Monad.Fail        as Fail (MonadFail (..))+import           Control.Monad.State       (MonadState (..), StateT (..), evalStateT)+import           Control.Monad.Except      (MonadError (..), ExceptT, runExceptT) import           Data.ByteString           (ByteString) import           Data.Map.Strict           (Map, fromList)-import           Data.Text                 (Text, pack)+import           Data.Text                 (Text)+import qualified Data.Text                 as T (unpack, pack) import           Data.Word                 (Word8) +-- |Error during unpack process+data UnpackError = NotNull+                 | NotInt+                 | NotFloat+                 | NotString+                 | NotBool+                 | NotList+                 | NotDict+                 | NotStructure+                 | NotValue+                 | Not Text+  deriving (Eq, Ord)++instance Show UnpackError where+  show NotNull      = "Not a Null value"+  show NotInt       = "Not an Int value"+  show NotFloat     = "Not a Float value"+  show NotString    = "Not a String value"+  show NotBool      = "Not a Bool value"+  show NotList      = "Not a List value"+  show NotDict      = "Not a Dict value"+  show NotStructure = "Not a Structure value"+  show NotValue     = "Not a Value value"+  show (Not what)   = "Not a " <> T.unpack what <> " (Structure) value"+ -- |The 'UnpackT' transformer helps to unpack a set of values from one 'ByteString'-type UnpackT = StateT ByteString+newtype UnpackT m a = UnpackT { runUnpackT :: ExceptT UnpackError (StateT ByteString m) a }+  deriving (Functor, Applicative, Monad, MonadError UnpackError, MonadState ByteString)  -- |The 'Structure' datatype describes Neo4j structure for BOLT protocol data Structure = Structure { signature :: Word8@@ -18,7 +51,7 @@  -- |Generalizes all datatypes that can be deserialized from 'Structure's. class FromStructure a where-  fromStructure :: Monad m => Structure -> m a+  fromStructure :: MonadError UnpackError m => Structure -> m a  -- |Generalizes all datatypes that can be serialized to 'Structure's. class ToStructure a where@@ -31,10 +64,21 @@   -- |Unpacks in a State monad to get values from single 'ByteString'   unpackT :: Monad m => UnpackT m a -  -- |Unpacks a 'ByteString' to selected value-  unpack :: Monad m  => ByteString -> m a-  unpack = evalStateT unpackT+-- |Unpacks a 'ByteString' to selected value+unpack :: (Monad m, BoltValue a)  => ByteString -> m (Either UnpackError a)+unpack = unpackAction unpackT +-- |Old-style unpack that runs 'fail' on error+unpackF :: (MonadFail m, BoltValue a) => ByteString -> m a+unpackF bs = do result <- unpack bs+                case result of+                  Right x -> pure x+                  Left  e -> Fail.fail $ show e++-- |Unpacks a 'ByteString' to selected value by some custom action+unpackAction :: Monad m => UnpackT m a -> ByteString -> m (Either UnpackError a)+unpackAction action = evalStateT (runExceptT $ runUnpackT action) + -- |The 'Value' datatype generalizes all primitive 'BoltValue's data Value = N ()            | B Bool@@ -77,7 +121,7 @@  instance IsValue Char where   toValue = toValueList . pure-  toValueList = T . Data.Text.pack+  toValueList = T . T.pack  instance IsValue a => IsValue [a] where   toValue = toValueList@@ -122,3 +166,4 @@                  , pathSequence      :: [Int]           -- ^Path sequence                  }   deriving (Show, Eq)+

@@ -23,43 +23,43 @@ unpackStreamTests =   describe "Unpack" $ do     it "unpacks integers correct" $ do-      u1 <- prepareData "01" >>= unpack :: IO Int+      u1 <- prepareData "01" >>= unpackF :: IO Int       u1 `shouldBe` 1-      u42 <- prepareData "2A" >>= unpack :: IO Int+      u42 <- prepareData "2A" >>= unpackF :: IO Int       u42 `shouldBe` 42-      u1234 <- prepareData "C904D2" >>= unpack :: IO Int+      u1234 <- prepareData "C904D2" >>= unpackF :: IO Int       u1234 `shouldBe` 1234     it "unpacks doubles correct" $ do-      u6d <- prepareData "C1401921FB54442D18" >>= unpack :: IO Double+      u6d <- prepareData "C1401921FB54442D18" >>= unpackF :: IO Double       u6d `shouldBe` 6.283185307179586-      um1d <- prepareData "C1BFF199999999999A" >>= unpack :: IO Double+      um1d <- prepareData "C1BFF199999999999A" >>= unpackF :: IO Double       um1d `shouldBe` (-1.1)     it "unpacks booleans correct" $ do-      uF <- prepareData "C2" >>= unpack :: IO Bool+      uF <- prepareData "C2" >>= unpackF :: IO Bool       uF `shouldBe` False-      uT <- prepareData "C3" >>= unpack :: IO Bool+      uT <- prepareData "C3" >>= unpackF :: IO Bool       uT `shouldBe` True     it "unpacks strings correct" $ do-      usE <- prepareData "80" >>= unpack :: IO Text+      usE <- prepareData "80" >>= unpackF :: IO Text       usE `shouldBe` T.pack ""-      usA <- prepareData "8141" >>= unpack :: IO Text+      usA <- prepareData "8141" >>= unpackF :: IO Text       usA `shouldBe` T.pack "A"-      usU <- prepareData "D0124772C3B6C39F656E6D61C39F7374C3A46265" >>= unpack :: IO Text+      usU <- prepareData "D0124772C3B6C39F656E6D61C39F7374C3A46265" >>= unpackF :: IO Text       usU `shouldBe` T.pack "Größenmaßstäbe"     it "unpacks lists correct" $ do-      ulE <- prepareData "90" >>= unpack :: IO [Int]+      ulE <- prepareData "90" >>= unpackF :: IO [Int]       ulE `shouldBe` []-      ulI <- prepareData "93010203" >>= unpack :: IO [Int]+      ulI <- prepareData "93010203" >>= unpackF :: IO [Int]       ulI `shouldBe` [1,2,3]-      ulL <- prepareData "D4280102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F202122232425262728" >>= unpack :: IO [Int]+      ulL <- prepareData "D4280102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F202122232425262728" >>= unpackF :: IO [Int]       ulL `shouldBe` [1..40]     it "unpacks dicts correct" $ do-      udE <- prepareData "A0" >>= unpack :: IO (Map Text ())+      udE <- prepareData "A0" >>= unpackF :: IO (Map Text ())       udE `shouldBe` M.fromList []-      udS <- prepareData "A1836F6E658465696E73" >>= unpack :: IO (Map Text Text)+      udS <- prepareData "A1836F6E658465696E73" >>= unpackF :: IO (Map Text Text)       udS `shouldBe` M.fromList [(T.pack "one", T.pack "eins")]     it "unpacks () correct" $ do-      uN <- prepareData "C0" >>= unpack :: IO ()+      uN <- prepareData "C0" >>= unpackF :: IO ()       uN `shouldBe` ()  packStreamTests :: Spec