diff --git a/hasbolt.cabal b/hasbolt.cabal --- a/hasbolt.cabal +++ b/hasbolt.cabal @@ -1,5 +1,5 @@ name: hasbolt -version: 0.1.7.1 +version: 0.1.7.2 synopsis: Haskell driver for Neo4j 3+ (BOLT protocol) description: Haskell driver for Neo4j 3+ (BOLT protocol). 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 @@ -9,29 +9,30 @@ import Database.Bolt.Value.Helpers import Database.Bolt.Value.Type -import Control.Monad (forM, replicateM) -import Control.Monad.Except (MonadError (..)) -import Data.Binary (Binary (..), Put, decode, encode) +import Control.Monad (forM, replicateM) +import Control.Monad.Except (MonadError (..)) +import Data.Binary (Binary (..), Put, decode, encode) import Data.Binary.Get -import Data.Binary.IEEE754 (doubleToWord, wordToDouble) -import Data.Binary.Put (putByteString, putWord16be, putWord32be, putWord64be, - putWord8) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.Binary.IEEE754 (doubleToWord, wordToDouble) +import Data.Binary.Put (putByteString, putWord16be, putWord32be, putWord64be, + putWord8) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Lazy (fromStrict, toStrict) import Data.Int -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) +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 GHC.Stack (HasCallStack, callStack, prettyCallStack) instance BoltValue () where pack () = putWord8 nullCode unpackT = getWord8 >>= unpackByMarker where unpackByMarker m | m == nullCode = pure () - | otherwise = fail "expected null" + | otherwise = failUnpack "null" m instance BoltValue Bool where pack True = putWord8 trueCode @@ -40,7 +41,7 @@ unpackT = getWord8 >>= unpackByMarker where unpackByMarker m | m == trueCode = pure True | m == falseCode = pure False - | otherwise = fail "expected bool" + | otherwise = failUnpack "bool" m instance BoltValue Int where pack int | isTinyInt int = putWord8 $ fromIntegral int @@ -56,14 +57,14 @@ | m == int16Code = toInt <$> getInt16be | m == int32Code = toInt <$> getInt32be | m == int64Code = toInt <$> getInt64be - | otherwise = fail "expected int" + | otherwise = failUnpack "int" m instance BoltValue Double where pack dbl = putWord8 doubleCode >> putWord64be (doubleToWord dbl) unpackT = getWord8 >>= unpackByMarker where unpackByMarker m | m == doubleCode = wordToDouble <$> getWord64be - | otherwise = fail "expected double" + | otherwise = failUnpack "double" m instance BoltValue Text where pack txt = mkPackedCollection (B.length bs) pbs (textConst, text8Code, text16Code, text32Code) @@ -75,7 +76,7 @@ | m == text8Code = toInt <$> getInt8 >>= unpackTextBySize | m == text16Code = toInt <$> getInt16be >>= unpackTextBySize | m == text32Code = toInt <$> getInt32be >>= unpackTextBySize - | otherwise = fail "expected text" + | otherwise = failUnpack "text" m unpackTextBySize size = do str <- getByteString size pure $! decodeUtf8 str @@ -88,7 +89,7 @@ | m == list8Code = toInt <$> getInt8 >>= unpackListBySize | m == list16Code = toInt <$> getInt16be >>= unpackListBySize | m == list32Code = toInt <$> getInt32be >>= unpackListBySize - | otherwise = fail "expected list" + | otherwise = failUnpack "list" m unpackListBySize size = forM [1..size] $ const unpackT instance BoltValue a => BoltValue (Map Text a) where @@ -98,10 +99,10 @@ unpackT = getWord8 >>= unpackByMarker where unpackByMarker m | isTinyDict m = unpackDictBySize (getSize m) - | m == dict8Code = toInt <$> getInt16be >>= unpackDictBySize + | m == dict8Code = toInt <$> getInt8 >>= unpackDictBySize | m == dict16Code = toInt <$> getInt16be >>= unpackDictBySize | m == dict32Code = toInt <$> getInt32be >>= unpackDictBySize - | otherwise = fail "expected dict" + | otherwise = failUnpack "dict" m unpackDictBySize = (M.fromList <$>) . unpackPairsBySize unpackPairsBySize size = forM [1..size] $ const $ do !key <- unpackT @@ -120,7 +121,7 @@ where unpackByMarker m | isTinyStruct m = unpackStructureBySize (getSize m) | m == struct8Code = toInt <$> getInt8 >>= unpackStructureBySize | m == struct16Code = toInt <$> getInt16be >>= unpackStructureBySize - | otherwise = fail "expected structure" + | otherwise = failUnpack "structure" m unpackStructureBySize size = Structure <$> getWord8 <*> replicateM size unpackT instance BoltValue Value where @@ -142,7 +143,7 @@ | isList m = L <$> unpackT | isDict m = M <$> unpackT | isStruct m = S <$> unpackT - | otherwise = fail "not value" + | otherwise = failUnpack "value" m -- = Structure instances for Neo4j structures @@ -207,3 +208,10 @@ size8 = 2^(8 :: Int) size16 = 2^(16 :: Int) size32 = 2^(32 :: Int) + +failUnpack :: (HasCallStack, MonadFail m) => String -> Word8 -> m a +failUnpack expected got = fail $ + "expected " <> expected <> ", got: " <> show got + <> (if null cs then "" else "\n" <> cs) + where + cs = prettyCallStack callStack 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 @@ -74,12 +74,12 @@ -- |The 'BoltValue' class describes values, that can be packed and unpacked for BOLT protocol. class BoltValue a where -- |Packs a value to 'ByteString' - pack :: a -> Put + pack :: HasCallStack => a -> Put -- |Unpacks in a State monad to get values from single 'ByteString' - unpackT :: Get a + unpackT :: HasCallStack => Get a -- |Unpacks a 'ByteString' to selected value -unpack :: (Monad m, BoltValue a) => ByteString -> m (Either UnpackError a) +unpack :: (Monad m, BoltValue a, HasCallStack) => ByteString -> m (Either UnpackError a) unpack = pure . unpackAction unpackT . fromStrict -- |Old-style unpack that runs 'fail' on error @@ -90,7 +90,7 @@ Left e -> Fail.fail $ show e -- |Unpacks a 'ByteString' to selected value by some custom action -unpackAction :: Get a -> BSL.ByteString -> Either UnpackError a +unpackAction :: HasCallStack => Get a -> BSL.ByteString -> Either UnpackError a unpackAction action bs = case runGetOrFail action bs of Left (_, _, err) -> Left $ BinaryError $ T.pack err Right (_, _, a) -> Right a