diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Criterion.Main +import Data.Binary.Put (runPut) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Lazy as BSL +import Data.Default + +import Database.Bolt (BoltCfg (..), Structure, connect, query, run) +import Database.Bolt.Serialization (pack, unpackAction, unpackT) + +main :: IO () +main = defaultMain + [ bgroup "unpackAction" + [ bench "unpack big node" $ nf + (either (error "wat") id . unpackAction @Structure unpackT) (BSL.fromStrict input) + ] + , bgroup "pack" + [ bench "pack big node" $ nf + (BSL.toStrict . runPut . pack) decodedInput + ] + , env (connect $ def { user = "neo4j", password = "test" }) + $ \pipe -> bgroup "Network tests" + [ bench "fetch big node" $ nfIO $ run pipe $ query "MATCH (b:BigNode) RETURN b" + ] + ] + +decodedInput :: Structure +decodedInput = either (error "wat") id $ unpackAction @Structure unpackT $ BSL.fromStrict input + +input :: ByteString +input = either (error "wat") id $ B64.decode + "sXGRs07JAf2Rh0JpZ05vZGWngWEqgWLJE4iBZACBZcFABb8Jlar3kINmb2/LAAAA6PJypSGBeMFACSH7TRLYSoR0ZXh00RhSTG9yZW0gaXBzdW0gZG9sb3Igc2l0IGFtZXQsIGNvbnNlY3RldHVyIGFkaXBpc2NpbmcgZWxpdC4gUGhhc2VsbHVzIGVnZXN0YXMgdGVtcHVzIHByZXRpdW0uIEluIGlkIHRyaXN0aXF1ZSBlcmF0LCBpZCBpbnRlcmR1bSBhdWd1ZS4gU2VkIG1hbGVzdWFkYSBtYXhpbXVzIGFyY3UsIHZlbCB1bHRyaWNpZXMgbGlndWxhIHRlbXBvciBmZXVnaWF0LiBVdCBlZ2V0IHRlbXB1cyB0dXJwaXMuIE1hdXJpcyBvcm5hcmUgdXQgbmliaCBhYyBzb2RhbGVzLiBPcmNpIHZhcml1cyBuYXRvcXVlIHBlbmF0aWJ1cyBldCBtYWduaXMgZGlzIHBhcnR1cmllbnQgbW9udGVzLCBuYXNjZXR1ciByaWRpY3VsdXMgbXVzLiBJbiBwb3J0dGl0b3IgZHVpIG1hc3NhLCB1dCBjb25kaW1lbnR1bSBlcm9zIGNvbmd1ZSBlZ2V0LiBQZWxsZW50ZXNxdWUgaGVuZHJlcml0IG5lcXVlIGxhY3VzLCBzZWQgdGVtcG9yIGVuaW0gbWF4aW11cyB2aXRhZS4gSW4gZmVsaXMgcXVhbSwgZmFjaWxpc2lzIGV1IG5pc2kgc2l0IGFtZXQsIGNvbW1vZG8gc2NlbGVyaXNxdWUgZG9sb3IuIENyYXMgYmliZW5kdW0gZXN0IGRvbG9yLCBzaXQgYW1ldCBhbGlxdWV0IGVyYXQgZWxlaWZlbmQgbm9uLiBOdWxsYW0gYWxpcXVhbSB0cmlzdGlxdWUgZG9sb3IgbmVjIHRpbmNpZHVudC4gU2VkIGF1Z3VlIHRlbGx1cywgZXVpc21vZCBzZWQgdGVtcG9yIGV1LCBwdWx2aW5hciBhdCBtYWduYS4gU2VkIGluIGF1Y3RvciBkdWkuIE51bGxhbSB2ZWwgdGVsbHVzIHBoYXJldHJhIG51bGxhIGZyaW5naWxsYSBpYWN1bGlzLiBQZWxsZW50ZXNxdWUgdmVsIGRvbG9yIG51bGxhLiBGdXNjZSBhY2N1bXNhbiBwbGFjZXJhdCBjb25ndWUuIE1vcmJpIG9ybmFyZSBmZWxpcyBleCwgdmVsIGNvbW1vZG8gbmVxdWUgcHVsdmluYXIgY29tbW9kby4gUHJhZXNlbnQgcXVpcyBsaWJlcm8gcXVpcyBmZWxpcyBjb25kaW1lbnR1bSBjb21tb2RvIGV1IG5vbiBkb2xvci4gUGVsbGVudGVzcXVlIHRlbXBvciB0ZWxsdXMgc2VkIGFsaXF1ZXQgaW1wZXJkaWV0LiBDbGFzcyBhcHRlbnQgdGFjaXRpIHNvY2lvc3F1IGFkIGxpdG9yYSB0b3JxdWVudCBwZXIgY29udWJpYSBub3N0cmEsIHBlciBpbmNlcHRvcyBoaW1lbmFlb3MuIERvbmVjIGFjIGNvbmRpbWVudHVtIHJpc3VzLiBEdWlzIHBvcnRhIGFudGUgaGVuZHJlcml0IGxvcmVtIGVnZXN0YXMsIHV0IHNjZWxlcmlzcXVlIG1pIGltcGVyZGlldC4gRnVzY2UgcG9ydGEgbWkgc2VkIGVyYXQgZGlnbmlzc2ltLCBjb25zZXF1YXQgZmF1Y2lidXMgbWV0dXMgdGluY2lkdW50LiBJbiBwb3J0dGl0b3IgbG9yZW0gbmVjIHRyaXN0aXF1ZSB0aW5jaWR1bnQuIE1hZWNlbmFzIGFsaXF1YW0gZG9sb3IgYXQgcGVsbGVudGVzcXVlIGltcGVyZGlldC4gQ3JhcyBibGFuZGl0IGVyb3MgcXVpcyBwbGFjZXJhdCBsYW9yZWV0LiBDdXJhYml0dXIgbm9uIGlhY3VsaXMgZWxpdC4gTWFlY2VuYXMgaWFjdWxpcyB0aW5jaWR1bnQgZGlhbSwgc2l0IGFtZXQgaW50ZXJkdW0gYW50ZSBjb25zZWN0ZXR1ciBuZWMuIE1vcmJpIGxvcmVtIG51bGxhLCBwb3J0YSBuZWMgaW1wZXJkaWV0IGEsIGxhb3JlZXQgaWQgbG9yZW0uIERvbmVjIGNvbmRpbWVudHVtIGFyY3UgYSBsYWNpbmlhIGNvbnNlY3RldHVyLiBDdXJhYml0dXIgdml0YWUgdml2ZXJyYSBsb3JlbSwgbm9uIGRhcGlidXMgbGliZXJvLiBBbGlxdWFtIHRpbmNpZHVudCBlbGVtZW50dW0gdGVsbHVzIHV0IGFjY3Vtc2FuLiBEb25lYyBzZWQgYWxpcXVhbSBqdXN0bywgZXQgcHVsdmluYXIgbGVjdHVzLiBWaXZhbXVzIGFjY3Vtc2FuIG5pc2wgYSBuZXF1ZSBhdWN0b3IsIGV1IHByZXRpdW0gbGFjdXMgZGlnbmlzc2ltLiBEb25lYyBlbGl0IGVzdCwgbWFsZXN1YWRhIHZpdGFlIHNhcGllbiBuZWMsIGRpY3R1bSB0cmlzdGlxdWUgdmVsaXQuIFN1c3BlbmRpc3NlIHRlbXB1cyBsb3JlbSBvZGlvLiBWZXN0aWJ1bHVtIHVsbGFtY29ycGVyIGxhY3VzIGV0IG1vbGVzdGllIGJpYmVuZHVtLiBTdXNwZW5kaXNzZSBwb3RlbnRpLiBTdXNwZW5kaXNzZSBzb2RhbGVzIG1hc3NhIGlkIHNlbSBldWlzbW9kIGxvYm9ydGlzIG5vbiBzaXQgYW1ldCBhdWd1ZS4gU3VzcGVuZGlzc2UgZXN0IGVzdCwgZGFwaWJ1cyB1bGxhbWNvcnBlciBuZXF1ZSBpbiwgbWFsZXN1YWRhIHZ1bHB1dGF0ZSBtYXVyaXMuIEZ1c2NlIGNvbnZhbGxpcyBwb3J0YSBkaWFtIG5vbiBibGFuZGl0LiBJbiBhdCB2dWxwdXRhdGUgZG9sb3IuIFNlZCBpbXBlcmRpZXQgZGljdHVtIHF1YW0gdml0YWUgY3Vyc3VzLiBNYWVjZW5hcyBmZWxpcyBhbnRlLCBwbGFjZXJhdCB2aXRhZSBpbnRlcmR1bSBwaGFyZXRyYSwgbWF0dGlzIG5vbiBzYXBpZW4uIE51bGxhbSBhYyB2ZWxpdCB0aW5jaWR1bnQsIGJsYW5kaXQgdGVsbHVzIHNpdCBhbWV0LCBzb2xsaWNpdHVkaW4gbGlndWxhLiBOdW5jIHZpdGFlIGVnZXN0YXMgbmlzbC4gSW50ZWdlciBmZXJtZW50dW0gdmVsIGVsaXQgaWQgcG9ydGEuIE51bmMgZXUgcG9ydGEgZXJhdC4gTWFlY2VuYXMgYWMgc2NlbGVyaXNxdWUgYXJjdS4gUHJhZXNlbnQgcHJldGl1bSBpbnRlcmR1bSBvcmNpIHZlbCBhY2N1bXNhbi4gU3VzcGVuZGlzc2UgZWdldCBudWxsYSBldSByaXN1cyBjb21tb2RvIGZldWdpYXQuIFByYWVzZW50IGZyaW5naWxsYSBlc3QgdmVsIGFudGUgbGFvcmVldCwgbmVjIGN1cnN1cyBtZXR1cyBzdXNjaXBpdC4gTWF1cmlzIGxhb3JlZXQgZXN0IGlkIHVybmEgZmVybWVudHVtIHBsYWNlcmF0LiBDcmFzIHZlc3RpYnVsdW0gbGVvIHNlZCBlbGl0IHVsbGFtY29ycGVyIGFjY3Vtc2FuIHZlbmVuYXRpcyBldSBtYXVyaXMuIE5hbSBkaWN0dW0gcHVsdmluYXIgZXN0LiBBZW5lYW4gdXQgZXJvcyBuZWMgZGlhbSBhbGlxdWFtIGNvbnZhbGxpcy4gUHJvaW4gZWxlaWZlbmQgbGlndWxhIHF1aXMgcGhhcmV0cmEgY29udmFsbGlzLiBDcmFzIGN1cnN1cywgYXVndWUgbm9uIHBvcnRhIG1vbGVzdGllLCBleCBtYXVyaXMgcG9zdWVyZSBsZWN0dXMsIHVsdHJpY2llcyBmYXVjaWJ1cyBvcmNpIHB1cnVzIGFjIGVuaW0uIE51bmMgYXQgbmVxdWUgdHJpc3RpcXVlLCBwZWxsZW50ZXNxdWUgYW50ZSBldCwgbW9sZXN0aWUgbmlzaS4gVXQgdWx0cmljZXMgYmliZW5kdW0gdm9sdXRwYXQuIEV0aWFtIGluIHVybmEgaW4gYXVndWUgaGVuZHJlcml0IGltcGVyZGlldCBzZWQgdXQgYXJjdS4gU2VkIGdyYXZpZGEgbmlzaSBzaXQgYW1ldCBmaW5pYnVzIHN1c2NpcGl0LiBOdW5jIG5lYyB0b3J0b3IgcXVpcyBvcmNpIGV1aXNtb2QgaW50ZXJkdW0uIE1hdXJpcyB2ZXN0aWJ1bHVtIGZlbGlzIGFjIG1hbGVzdWFkYSBldWlzbW9kLiBQcmFlc2VudCBhbGlxdWV0IG5lcXVlIHV0IGxpYmVybyBoZW5kcmVyaXQgc3VzY2lwaXQgbmVjIGV1IGxpYmVyby4gU2VkIHV0IGFudGUgc2VkIHVybmEgcG9ydHRpdG9yIGZhY2lsaXNpcy4gU3VzcGVuZGlzc2UgZGljdHVtIGF1Y3RvciB1bGxhbWNvcnBlci4gRG9uZWMgZWdldCBleCBhdCBuaWJoIGVnZXN0YXMgZWxlbWVudHVtLiBGdXNjZSBldSBqdXN0byBldWlzbW9kLCBzb2RhbGVzIG5pYmggZXQsIHRlbXB1cyBlbGl0LiBDcmFzIGluIGVuaW0gc2VtLiBVdCBwdWx2aW5hciBhdWd1ZSBldCBsaWd1bGEgaW50ZXJkdW0sIHNlZCB0ZW1wdXMgcmlzdXMgdmVzdGlidWx1bS4gTmFtIGN1cnN1cyBzZWQgYXVndWUgZXQgcG9ydHRpdG9yLiBTZWQgcmhvbmN1cyBpZCBmZWxpcyBuZWMgcGhhcmV0cmEuIFNlZCBmZXVnaWF0IHRpbmNpZHVudCBkdWksIGV1IHVsdHJpY2llcyBvcmNpIGltcGVyZGlldCBhYy4gVXQgYWMgYmxhbmRpdCB0b3J0b3IuIEZ1c2NlIGVmZmljaXR1ciwgZW5pbSBuZWMgZmF1Y2lidXMgdGVtcG9yLCB0dXJwaXMgbGVjdHVzIGRpZ25pc3NpbSBsZWN0dXMsIGEgY29uc2VxdWF0IG5pc2kgdmVsaXQgdml0YWUgZW5pbS4gUGhhc2VsbHVzIHRpbmNpZHVudCB1bHRyaWNpZXMgZGlhbSwgZXUgYXVjdG9yIGRvbG9yIHZhcml1cyBlZ2V0LiBTZWQgc2VkIGxpYmVybyB2dWxwdXRhdGUsIGRhcGlidXMgZG9sb3IgdXQsIHZ1bHB1dGF0ZSBqdXN0by4gVXQgZnJpbmdpbGxhIGVsaXQgYW50ZSwgc2VkIHNjZWxlcmlzcXVlIHR1cnBpcyBibGFuZGl0IHNpdCBhbWV0LiBQZWxsZW50ZXNxdWUgYXQgbmlzaSB2ZWxpdC4gRG9uZWMgY29uZGltZW50dW0gdmVsaXQgcXVpcyBkdWkgbW9sZXN0aWUgdWx0cmljZXMuIE5hbSB1dCBudW5jIHR1cnBpcy4gRHVpcyBsb2JvcnRpcyBuaWJoIGluIG1ldHVzIHZhcml1cyBkaWN0dW0uIEFsaXF1YW0gc2l0IGFtZXQgZW5pbSBldCBpcHN1bSBmcmluZ2lsbGEgY29tbW9kby4gUHJvaW4gcmhvbmN1cyBuZXF1ZSBzYXBpZW4sIGFjIGltcGVyZGlldCBhbnRlIHVsdHJpY2VzIHV0LiBVdCBuZWMgbmlzbCBwbGFjZXJhdCwgcHVsdmluYXIgbnVuYyB1dCwgb3JuYXJlIG5lcXVlLiBTZWQgZnJpbmdpbGxhIHZpdmVycmEgbWkgdmVsIGNvbW1vZG8uIEV0aWFtIGVmZmljaXR1ciBzaXQgYW1ldCBtaSBldCB0aW5jaWR1bnQuIFNlZCBtYXhpbXVzIGF1Z3VlIHNpdCBhbWV0IGxpZ3VsYSBzb2xsaWNpdHVkaW4gY29uc2VjdGV0dXIuIEludGVnZXIgZWxlbWVudHVtIHNhcGllbiBzaXQgYW1ldCBlbmltIHB1bHZpbmFyIHZlaGljdWxhLiBJbnRlZ2VyIGlkIGFudGUgc2VkIHNhcGllbiBwZWxsZW50ZXNxdWUgbG9ib3J0aXMuIFByYWVzZW50IHZpdGFlIGZhY2lsaXNpcyBmZWxpcywgcXVpcyB0aW5jaWR1bnQgbnVuYy4gRG9uZWMgaWQgcnV0cnVtIG9kaW8uIE51bGxhIHZpdGFlIHB1cnVzIGV1IGVuaW0gZGFwaWJ1cyBsb2JvcnRpcyBhIGlkIGRvbG9yLiBOdWxsYW0gdGluY2lkdW50IGV1IGFudGUgYSBhbGlxdWV0LiBQaGFzZWxsdXMgdm9sdXRwYXQgdXJuYSBuZWMgdmVsaXQgYmxhbmRpdCwgaW4gc29sbGljaXR1ZGluIGxpYmVybyB2b2x1dHBhdC4gTWFlY2VuYXMgc2NlbGVyaXNxdWUgYWxpcXVhbSBlcmF0IGVnZXQgbWF4aW11cy4gRnVzY2UgY3Vyc3VzIHBoYXJldHJhIGRpZ25pc3NpbS4gVXQgYWxpcXVhbSwgcHVydXMgYSBhdWN0b3IgcG9ydHRpdG9yLCBlcm9zIHRlbGx1cyBtYWxlc3VhZGEgZXN0LCBxdWlzIGhlbmRyZXJpdCBkaWFtIHR1cnBpcyB1dCBleC4gQ2xhc3MgYXB0ZW50IHRhY2l0aSBzb2Npb3NxdSBhZCBsaXRvcmEgdG9ycXVlbnQgcGVyIGNvbnViaWEgbm9zdHJhLCBwZXIgaW5jZXB0b3MgaGltZW5hZW9zLiBRdWlzcXVlIGZhdWNpYnVzLCB0b3J0b3IgYSBwaGFyZXRyYSBzdXNjaXBpdCwgaXBzdW0gYXVndWUgaGVuZHJlcml0IG5lcXVlLCBldCBhdWN0b3IgbmlzbCBmZWxpcyBxdWlzIGR1aS4gUXVpc3F1ZSByaG9uY3VzIGR1aSBhdCBwbGFjZXJhdCBzb2xsaWNpdHVkaW4uIE1hdXJpcyBydXRydW0gbHVjdHVzIHR1cnBpcy4gUXVpc3F1ZSBzY2VsZXJpc3F1ZSBsYWN1cyBtYXVyaXMsIHF1aXMgbWF4aW11cyBwdXJ1cyBzY2VsZXJpc3F1ZSBub24uIFV0IGV0IGVzdCBzaXQgYW1ldCBxdWFtIGxhb3JlZXQgcHJldGl1bSBpbiBhdCB0b3J0b3IuIE51bGxhbSBhcmN1IGRpYW0sIGF1Y3RvciBiaWJlbmR1bSBsZWN0dXMgZXQsIGJsYW5kaXQgbGFjaW5pYSBxdWFtLiBBbGlxdWFtIGFsaXF1YW0gcG9zdWVyZSBuaXNsIGF0IGFjY3Vtc2FuLiBQaGFzZWxsdXMgYSBwb3N1ZXJlIGRpYW0sIG5lYyBiaWJlbmR1bSBzZW0uIFN1c3BlbmRpc3NlIGludGVyZHVtIG1hc3NhIGVsaXQsIHF1aXMgZmV1Z2lhdCBuaXNpIHZlaGljdWxhIHZpdGFlLiBTZWQgZHVpIG1hdXJpcywgZWxlbWVudHVtIGV0IGFudGUgcXVpcywgdnVscHV0YXRlIGVmZmljaXR1ciBsaWJlcm8uIE5hbSBhbGlxdWV0IGVsaXQgYWMgbGliZXJvIGFsaXF1ZXQsIGVnZXQgZmluaWJ1cyBuaXNpIHRpbmNpZHVudC4gU3VzcGVuZGlzc2UgdmVsIG5pc2wgaW4gdGVsbHVzIHBoYXJldHJhIGdyYXZpZGEgZXQgdml0YWUgbWF1cmlzLiBDdXJhYml0dXIgcG9zdWVyZSBjb252YWxsaXMgYWxpcXVldC4gTnVsbGFtIHNlZCBlc3QgYXQgbmlzbCBhdWN0b3IgbGFjaW5pYSBpZCBzaXQgYW1ldCBtYWduYS4gTnVsbGEgZXQgdG9ydG9yIHR1cnBpcy4gU3VzcGVuZGlzc2Ugc2FwaWVuIGVyb3MsIGZlcm1lbnR1bSBxdWlzIHBlbGxlbnRlc3F1ZSB2ZWwsIGRpZ25pc3NpbSB2ZWwgdXJuYS4gQWxpcXVhbSBuaXNpIG1hdXJpcywgc2NlbGVyaXNxdWUgZWdldCBuaWJoIHF1aXMsIGNvbnNlY3RldHVyIGZlcm1lbnR1bSBqdXN0by4gUHJhZXNlbnQgZWdldCBlbGVtZW50dW0gaXBzdW0uIFNlZCBuaWJoIG1pLCB0aW5jaWR1bnQgcXVpcyBuaWJoIHV0LCB1bHRyaWNpZXMgZmFjaWxpc2lzIG5lcXVlLg==" diff --git a/hasbolt.cabal b/hasbolt.cabal --- a/hasbolt.cabal +++ b/hasbolt.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: hasbolt -version: 0.1.5.0 +version: 0.1.6.0 license: BSD3 license-file: LICENSE copyright: (c) 2018 Pavel Yakovlev @@ -68,7 +68,9 @@ mtl >=2.2.0 && <2.3, network >=2.6.3.1 && <3.2, connection >=0.2.8 && <0.4, - data-default >=0.7.1.1 && <0.8 + data-default >=0.7.1.1 && <0.8, + deepseq >=1.4.4.0 && <1.5, + deepseq-generics >=0.2.0.0 && <0.3 if impl(ghc <8.6) build-depends: contravariant >=1.4.1 && <1.6 @@ -90,4 +92,21 @@ QuickCheck >=2.9 && <2.15, text >=1.2.4.1 && <1.3, containers >=0.6.2.1 && <0.7, + binary >=0.8.8.0 && <0.9, bytestring >=0.10.12.0 && <0.11 + +benchmark hasbolt-bench + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -eventlog + build-depends: + base >=4.14.1.0 && <4.15, + base64-bytestring >=1.1.0.0 && <1.2, + binary >=0.8.8.0 && <0.9, + bytestring >=0.10.12.0 && <0.11, + criterion >=1.5.9.0 && <1.6, + data-default >=0.7.1.1 && <0.8, + hasbolt -any, + hspec >=2.7.8 && <2.8 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 @@ -3,21 +3,26 @@ {-# LANGUAGE RecordWildCards #-} module Database.Bolt.Connection.Pipe where +import qualified Database.Bolt.Connection.Connection as C (close, connect, recv, send, sendMany) import Database.Bolt.Connection.Instances import Database.Bolt.Connection.Type import Database.Bolt.Value.Helpers import Database.Bolt.Value.Instances -import Database.Bolt.Value.Type -import qualified Database.Bolt.Connection.Connection as C (close, connect, recv, - send, sendMany) +import Database.Bolt.Value.Type (BoltValue (pack, unpackT), + FromStructure (fromStructure), + ToStructure (toStructure), unpackAction) import Control.Exception (throwIO) import Control.Monad (forM_, unless, void, when) -import Control.Monad.Except (MonadError (..), ExceptT, runExceptT) +import Control.Monad.Except (ExceptT, MonadError (..), runExceptT) import Control.Monad.Trans (MonadIO (..)) +import Data.Binary (decode) +import Data.Binary.Put (runPut) import Data.ByteString (ByteString) -import qualified Data.ByteString as B (concat, length, null, - splitAt) +import qualified Data.ByteString as B (concat, length) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Internal as BSL +import Data.Int (Int64) import Data.Word (Word16) import GHC.Stack (HasCallStack) @@ -73,7 +78,7 @@ flush :: MonadPipe m => HasCallStack => Pipe -> Request -> m () flush pipe request = do forM_ chunks $ C.sendMany conn . mkChunk C.send conn terminal - where bs = pack $ toStructure request + where bs = runPut $ pack $ toStructure request chunkSize = chunkSizeFor (mcs pipe) bs chunks = split chunkSize bs terminal = encodeStrict (0 :: Word16) @@ -84,18 +89,21 @@ in [encodeStrict size, chunk] fetch :: MonadPipe m => HasCallStack => Pipe -> m Response -fetch pipe = do bs <- B.concat <$> chunks - response <- flip unpackAction bs $ unpackT >>= fromStructure - either (throwError . WrongMessageFormat) pure response +fetch pipe = do bs <- chunks + let response = unpackAction unpackT bs >>= fromStructure + case response of + Left ue -> throwError $ WrongMessageFormat ue + Right a -> pure a + where conn = connection pipe - chunks :: MonadPipe m => m [ByteString] - chunks = do size <- decodeStrict <$> recvChunk conn 2 + chunks :: MonadPipe m => m BSL.ByteString + chunks = do size <- decode <$> recvChunk conn 2 chunk <- recvChunk conn size - if B.null chunk - then pure [] + if BSL.null chunk + then pure BSL.empty else do rest <- chunks - pure (chunk:rest) + pure $! chunk <> rest -- Helper functions @@ -103,7 +111,7 @@ handshake pipe bcfg = do let conn = connection pipe C.send conn (encodeStrict $ magic bcfg) C.send conn (boltVersionProposal bcfg) - serverVersion <- decodeStrict <$> recvChunk conn 4 + serverVersion <- decode <$> recvChunk conn 4 when (serverVersion /= version bcfg) $ throwError UnsupportedServerVersion flush pipe (createInit bcfg) @@ -114,21 +122,21 @@ boltVersionProposal :: BoltCfg -> ByteString boltVersionProposal bcfg = B.concat $ encodeStrict <$> [version bcfg, 0, 0, 0] -recvChunk :: MonadPipe m => HasCallStack => ConnectionWithTimeout -> Word16 -> m ByteString -recvChunk conn size = B.concat <$> helper (fromIntegral size) - where helper :: MonadPipe m => Int -> m [ByteString] - helper 0 = pure [] +recvChunk :: MonadPipe m => HasCallStack => ConnectionWithTimeout -> Word16 -> m BSL.ByteString +recvChunk conn size = helper (fromIntegral size) + where helper :: MonadPipe m => Int -> m BSL.ByteString + helper 0 = pure BSL.empty helper sz = do mbChunk <- C.recv conn sz case mbChunk of - Just chunk -> (chunk:) <$> helper (sz - B.length chunk) + Just chunk -> BSL.chunk chunk <$> helper (sz - B.length chunk) Nothing -> throwError CannotReadChunk -chunkSizeFor :: Word16 -> ByteString -> Int +chunkSizeFor :: Word16 -> BSL.ByteString -> Int64 chunkSizeFor maxSize bs = 1 + div len noc - where len = B.length bs + where len = BSL.length bs noc = 1 + div len (fromIntegral maxSize) -split :: Int -> ByteString -> [ByteString] -split size bs | B.null bs = [] - | otherwise = let (chunk, rest) = B.splitAt size bs - in chunk : split size rest +split :: Int64 -> BSL.ByteString -> [ByteString] +split size bs | BSL.null bs = [] + | otherwise = let (chunk, rest) = BSL.splitAt size bs + in BSL.toStrict chunk : split size rest 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 @@ -7,6 +7,7 @@ import Database.Bolt.Value.Type hiding (unpack) +import Control.DeepSeq (NFData(..), rwhnf) import Control.Exception (Exception (..), SomeException, handle) import Control.Monad.Trans (MonadTrans (..), MonadIO (..)) import Control.Monad.Reader (MonadReader (..), ReaderT) @@ -109,6 +110,9 @@ , mcs :: Word16 -- ^Driver maximum chunk size of request , pipe_version :: Word32 -- ^Connection version 0000mnMJ } + +instance NFData Pipe where + rnf = rwhnf data AuthToken = AuthToken { scheme :: Text , principal :: Text 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,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Database.Bolt.Value.Instances where @@ -10,12 +11,13 @@ 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 (Binary (..), Put, decode, encode) +import Data.Binary.Get import Data.Binary.IEEE754 (doubleToWord, wordToDouble) -import Data.ByteString (ByteString, append, cons, - singleton) +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 @@ -26,101 +28,101 @@ import Data.Word instance BoltValue () where - pack () = singleton nullCode + pack () = putWord8 nullCode - unpackT = unpackW8 >>= unpackByMarker + unpackT = getWord8 >>= unpackByMarker where unpackByMarker m | m == nullCode = pure () - | otherwise = throwError NotNull + | otherwise = fail "expected null" instance BoltValue Bool where - pack True = singleton trueCode - pack False = singleton falseCode + pack True = putWord8 trueCode + pack False = putWord8 falseCode - unpackT = unpackW8 >>= unpackByMarker + unpackT = getWord8 >>= unpackByMarker where unpackByMarker m | m == trueCode = pure True | m == falseCode = pure False - | otherwise = throwError NotBool + | otherwise = fail "expected bool" instance BoltValue Int where - pack int | isTinyInt int = encodeStrict (fromIntegral int :: Word8) - | 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 62 int = cons int64Code $ encodeStrict (fromIntegral int :: Word64) + pack int | isTinyInt int = putWord8 $ fromIntegral int + | isIntX 8 int = putWord8 int8Code >> putWord8 (fromIntegral int) + | isIntX 16 int = putWord8 int16Code >> putWord16be (fromIntegral int :: Word16) + | isIntX 32 int = putWord8 int32Code >> putWord32be (fromIntegral int :: Word32) + | isIntX 62 int = putWord8 int64Code >> putWord64be (fromIntegral int :: Word64) | otherwise = error "Cannot pack so large integer" - unpackT = unpackW8 >>= unpackByMarker + unpackT = getWord8 >>= unpackByMarker where unpackByMarker m | isTinyWord m = pure . toInt $ (fromIntegral m :: Int8) - | m == int8Code = toInt <$> unpackI8 - | m == int16Code = toInt <$> unpackI16 - | m == int32Code = toInt <$> unpackI32 - | m == int64Code = toInt <$> unpackI64 - | otherwise = throwError NotInt + | m == int8Code = toInt <$> getInt8 + | m == int16Code = toInt <$> getInt16be + | m == int32Code = toInt <$> getInt32be + | m == int64Code = toInt <$> getInt64be + | otherwise = fail "expected int" instance BoltValue Double where - pack dbl = cons doubleCode $ encodeStrict (doubleToWord dbl) + pack dbl = putWord8 doubleCode >> putWord64be (doubleToWord dbl) - unpackT = unpackW8 >>= unpackByMarker - where unpackByMarker m | m == doubleCode = wordToDouble <$> unpackW64 - | otherwise = throwError NotFloat + unpackT = getWord8 >>= unpackByMarker + where unpackByMarker m | m == doubleCode = wordToDouble <$> getWord64be + | otherwise = fail "expected double" instance BoltValue Text where - pack txt = mkPackedCollection (B.length pbs) pbs (textConst, text8Code, text16Code, text32Code) - where pbs = encodeUtf8 txt + pack txt = mkPackedCollection (B.length bs) pbs (textConst, text8Code, text16Code, text32Code) + where bs = encodeUtf8 txt + pbs = putByteString bs - unpackT = unpackW8 >>= unpackByMarker + unpackT = getWord8 >>= unpackByMarker where unpackByMarker m | isTinyText m = unpackTextBySize (getSize m) - | m == text8Code = toInt <$> unpackW8 >>= unpackTextBySize - | m == text16Code = toInt <$> unpackW16 >>= unpackTextBySize - | m == text32Code = toInt <$> unpackW32 >>= unpackTextBySize - | otherwise = throwError NotString - unpackTextBySize size = do str <- gets (B.take size) - modify (B.drop size) - pure $ decodeUtf8 str + | m == text8Code = toInt <$> getInt8 >>= unpackTextBySize + | m == text16Code = toInt <$> getInt16be >>= unpackTextBySize + | m == text32Code = toInt <$> getInt32be >>= unpackTextBySize + | otherwise = fail "expected text" + unpackTextBySize size = do str <- getByteString size + pure $! decodeUtf8 str instance BoltValue a => BoltValue [a] where pack lst = mkPackedCollection (length lst) pbs (listConst, list8Code, list16Code, list32Code) - where pbs = B.concat $ map pack lst + where pbs = mapM_ pack lst - unpackT = unpackW8 >>= unpackByMarker + unpackT = getWord8 >>= unpackByMarker where unpackByMarker m | isTinyList m = unpackListBySize (getSize m) - | m == list8Code = toInt <$> unpackW8 >>= unpackListBySize - | m == list16Code = toInt <$> unpackW16 >>= unpackListBySize - | m == list32Code = toInt <$> unpackW32 >>= unpackListBySize - | otherwise = throwError NotList + | m == list8Code = toInt <$> getInt8 >>= unpackListBySize + | m == list16Code = toInt <$> getInt16be >>= unpackListBySize + | m == list32Code = toInt <$> getInt32be >>= unpackListBySize + | otherwise = fail "expected list" unpackListBySize size = forM [1..size] $ const unpackT instance BoltValue a => BoltValue (Map Text a) where 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 + where pbs = mapM_ mkPairPack $ M.assocs dict + mkPairPack (key, val) = pack key >> pack val - unpackT = unpackW8 >>= unpackByMarker + unpackT = getWord8 >>= unpackByMarker where unpackByMarker m | isTinyDict m = unpackDictBySize (getSize m) - | m == dict8Code = toInt <$> unpackW8 >>= unpackDictBySize - | m == dict16Code = toInt <$> unpackW16 >>= unpackDictBySize - | m == dict32Code = toInt <$> unpackW32 >>= unpackDictBySize - | otherwise = throwError NotDict + | m == dict8Code = toInt <$> getInt16be >>= unpackDictBySize + | m == dict16Code = toInt <$> getInt16be >>= unpackDictBySize + | m == dict32Code = toInt <$> getInt32be >>= unpackDictBySize + | otherwise = fail "expected dict" unpackDictBySize = (M.fromList <$>) . unpackPairsBySize unpackPairsBySize size = forM [1..size] $ const $ do - key <- unpackT - value <- unpackT + !key <- unpackT + !value <- unpackT pure (key, value) 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 + pack (Structure sig lst) | size < size4 = putWord8 (structConst + fromIntegral size) >> pData + | size < size8 = putWord8 struct8Code >> putWord8 (fromIntegral size) >> pData + | size < size16 = putWord8 struct16Code >> putWord16be size >> pData | otherwise = error "Cannot pack so large structure" where size = fromIntegral $ length lst :: Word16 - pData = sig `cons` B.concat (map pack lst) + pData = putWord8 sig >> mapM_ pack lst - unpackT = unpackW8 >>= unpackByMarker + unpackT = getWord8 >>= unpackByMarker where unpackByMarker m | isTinyStruct m = unpackStructureBySize (getSize m) - | m == struct8Code = toInt <$> unpackW8 >>= unpackStructureBySize - | m == struct16Code = toInt <$> unpackW16 >>= unpackStructureBySize - | otherwise = throwError NotStructure - unpackStructureBySize size = Structure <$> unpackW8 <*> replicateM size unpackT + | m == struct8Code = toInt <$> getInt8 >>= unpackStructureBySize + | m == struct16Code = toInt <$> getInt16be >>= unpackStructureBySize + | otherwise = fail "expected structure" + unpackStructureBySize size = Structure <$> getWord8 <*> replicateM size unpackT instance BoltValue Value where pack (N n) = pack n @@ -132,7 +134,7 @@ pack (M m) = pack m pack (S s) = pack s - unpackT = observeW8 >>= unpackByMarker + unpackT = lookAhead getWord8 >>= unpackByMarker where unpackByMarker m | isNull m = N <$> unpackT | isBool m = B <$> unpackT | isInt m = I <$> unpackT @@ -141,7 +143,7 @@ | isList m = L <$> unpackT | isDict m = M <$> unpackT | isStruct m = S <$> unpackT - | otherwise = throwError NotValue + | otherwise = fail "not value" -- = Structure instances for Neo4j structures @@ -153,7 +155,7 @@ where cnvT [] = pure [] cnvT (T x:xs) = (x:) <$> cnvT xs - cnvT _ = throwError NotString + cnvT _ = throwError NotString instance FromStructure Relationship where fromStructure struct = @@ -168,7 +170,7 @@ _ -> throwError $ Not "URelationship" instance FromStructure Path where - fromStructure struct = + 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" @@ -176,77 +178,29 @@ 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 - + cnvR _ = throwError NotStructure + cnvI [] = pure [] cnvI (I x:xs) = (x:) <$> cnvI xs cnvI _ = throwError NotInt --- = Integer values unpackers - -observeW8 :: Monad m => UnpackT m Word8 -observeW8 = observeNum 1 - -unpackW8 :: Monad m => UnpackT m Word8 -unpackW8 = unpackNum 1 - -unpackW16 :: Monad m => UnpackT m Word16 -unpackW16 = unpackNum 2 - -unpackW32 :: Monad m => UnpackT m Word32 -unpackW32 = unpackNum 4 - -unpackW64 :: Monad m => UnpackT m Word64 -unpackW64 = unpackNum 8 - -unpackI8 :: Monad m => UnpackT m Int8 -unpackI8 = unpackNum 1 - -unpackI16 :: Monad m => UnpackT m Int16 -unpackI16 = unpackNum 2 - -unpackI32 :: Monad m => UnpackT m Int32 -unpackI32 = unpackNum 4 - -unpackI64 :: Monad m => UnpackT m Int64 -unpackI64 = unpackNum 8 - --- = Other helpers - --- |Unpacks n bytes as a numeric type -observeNum :: (Monad m, Binary a) => Int -> UnpackT m a -observeNum = (decodeStrict <$>) . topBS - -unpackNum :: (Monad m, Binary a) => Int -> UnpackT m a -unpackNum = (decodeStrict <$>) . popBS - decodeStrict :: Binary a => ByteString -> a decodeStrict = decode . fromStrict encodeStrict :: Binary a => a -> ByteString encodeStrict = toStrict . encode --- |Obtain first n bytes of 'ByteString' -topBS :: Monad m => Int -> UnpackT m ByteString -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 (B.drop size) - pure top - -- |Pack collection using it's size and set of BOLT constants -mkPackedCollection :: Int -> ByteString -> (Word8, Word8, Word8, Word8) -> ByteString +mkPackedCollection :: Int -> Put -> (Word8, Word8, Word8, Word8) -> Put 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 + | size < size4 = putWord8 (wt + fromIntegral size) >> bst + | size < size8 = putWord8 w8 >> putWord8 (fromIntegral size) >> bst + | size < size16 = putWord8 w16 >> putWord16be (fromIntegral size :: Word16) >> bst + | size < size32 = putWord8 w32 >> putWord32be (fromIntegral size :: Word32) >> bst | otherwise = error "Cannot pack so large collection" size4,size8, size16,size32 :: Integral a => a 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 @@ -1,19 +1,28 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DerivingStrategies #-} module Database.Bolt.Value.Type where +import Control.DeepSeq (NFData) +import Control.Monad.Except (ExceptT, MonadError (..)) import Control.Monad.Fail as Fail (MonadFail (..)) -import Control.Monad.State (MonadState (..), StateT (..), evalStateT) -import Control.Monad.Except (MonadError (..), ExceptT, runExceptT) +import Control.Monad.State (MonadState (..), StateT (..)) +import Data.Binary.Get +import Data.Binary.Put import Data.ByteString (ByteString) +import Data.ByteString.Lazy (fromStrict) +import qualified Data.ByteString.Lazy as BSL import Data.Map.Strict (Map, fromList) import Data.Monoid ((<>)) import Data.Text (Text) -import qualified Data.Text as T (unpack, pack) +import qualified Data.Text as T (pack, unpack) import Data.Word (Word8) +import GHC.Generics (Generic) -- |Error during unpack process data UnpackError = NotNull @@ -25,6 +34,7 @@ | NotDict | NotStructure | NotValue + | BinaryError Text | Not Text deriving (Eq, Ord) @@ -38,17 +48,19 @@ show NotDict = "Not a Dict value" show NotStructure = "Not a Structure value" show NotValue = "Not a Value value" + show (BinaryError what) = "Error while decoding binary format: " <> T.unpack what show (Not what) = "Not a " <> T.unpack what <> " (Structure) value" -- |The 'UnpackT' transformer helps to unpack a set of values from one 'ByteString' newtype UnpackT m a = UnpackT { runUnpackT :: ExceptT UnpackError (StateT ByteString m) a } - deriving (Functor, Applicative, Monad, MonadError UnpackError, MonadState ByteString) + deriving newtype (Functor, Applicative, Monad, MonadError UnpackError, MonadState ByteString) -- |The 'Structure' datatype describes Neo4j structure for BOLT protocol data Structure = Structure { signature :: Word8 , fields :: [Value] } - deriving (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) -- |Generalizes all datatypes that can be deserialized from 'Structure's. class FromStructure a where @@ -61,24 +73,26 @@ -- |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 -> ByteString + pack :: a -> Put -- |Unpacks in a State monad to get values from single 'ByteString' - unpackT :: Monad m => UnpackT m a + unpackT :: Get a -- |Unpacks a 'ByteString' to selected value unpack :: (Monad m, BoltValue a) => ByteString -> m (Either UnpackError a) -unpack = unpackAction unpackT +unpack = pure . unpackAction unpackT . fromStrict -- |Old-style unpack that runs 'fail' on error unpackF :: (MonadFail m, BoltValue a) => ByteString -> m a -unpackF bs = do result <- unpack bs +unpackF bs = do let result = unpackAction unpackT $ fromStrict 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) +unpackAction :: 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 -- |The 'Value' datatype generalizes all primitive 'BoltValue's data Value = N () @@ -89,7 +103,8 @@ | L [Value] | M (Map Text Value) | S Structure - deriving (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) -- |Every datatype that can be represented as BOLT protocol value class IsValue a where diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} import Control.Applicative ((<$>)) +import Data.Binary.Put (runPut) import Data.ByteString (ByteString) import Data.ByteString.Lazy (fromStrict, toStrict) import Hex @@ -22,6 +23,9 @@ packStreamTests unpackStreamTests +pack' :: BoltValue a => a -> ByteString +pack' = toStrict . runPut . pack + unpackStreamTests :: Spec unpackStreamTests = describe "Unpack" $ do @@ -69,29 +73,29 @@ packStreamTests = describe "Pack" $ do it "packs integers correct" $ do - hex (pack (1::Int)) `shouldBe` "01" - hex (pack (42::Int)) `shouldBe` "2A" - hex (pack (1234::Int)) `shouldBe` "C904D2" + hex (pack' (1::Int)) `shouldBe` "01" + hex (pack' (42::Int)) `shouldBe` "2A" + hex (pack' (1234::Int)) `shouldBe` "C904D2" it "packs doubles correct" $ do - hex (pack (6.283185307179586::Double)) `shouldBe` "C1401921FB54442D18" - hex (pack (-1.1::Double)) `shouldBe` "C1BFF199999999999A" + hex (pack' (6.283185307179586::Double)) `shouldBe` "C1401921FB54442D18" + hex (pack' (-1.1::Double)) `shouldBe` "C1BFF199999999999A" it "packs booleans correct" $ do - hex (pack False) `shouldBe` "C2" - hex (pack True) `shouldBe` "C3" + hex (pack' False) `shouldBe` "C2" + hex (pack' True) `shouldBe` "C3" it "packs strings correct" $ do - hex (pack $ T.pack "") `shouldBe` "80" - hex (pack $ T.pack "A") `shouldBe` "8141" - hex (pack $ T.pack "Größenmaßstäbe") `shouldBe` "D0124772C3B6C39F656E6D61C39F7374C3A46265" - hex (pack $ T.pack "ABCDEFGHIJKLMNOPQRSTUVWXYZ") `shouldBe` "D01A4142434445464748494A4B4C4D4E4F505152535455565758595A" + hex (pack' $ T.pack "") `shouldBe` "80" + hex (pack' $ T.pack "A") `shouldBe` "8141" + hex (pack' $ T.pack "Größenmaßstäbe") `shouldBe` "D0124772C3B6C39F656E6D61C39F7374C3A46265" + hex (pack' $ T.pack "ABCDEFGHIJKLMNOPQRSTUVWXYZ") `shouldBe` "D01A4142434445464748494A4B4C4D4E4F505152535455565758595A" it "packs lists correct" $ do - hex (pack ([]::[Int])) `shouldBe` "90" - hex (pack ([1,2,3]::[Int])) `shouldBe` "93010203" - hex (pack ([1..40]::[Int])) `shouldBe` "D4280102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F202122232425262728" + hex (pack' ([]::[Int])) `shouldBe` "90" + hex (pack' ([1,2,3]::[Int])) `shouldBe` "93010203" + hex (pack' ([1..40]::[Int])) `shouldBe` "D4280102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F202122232425262728" it "packs dicts correct" $ do - hex (pack (M.empty :: Map Text ())) `shouldBe` "A0" - hex (pack (M.fromList [(T.pack "one", T.pack "eins")])) `shouldBe` "A1836F6E658465696E73" + hex (pack' (M.empty :: Map Text ())) `shouldBe` "A0" + hex (pack' (M.fromList [(T.pack "one", T.pack "eins")])) `shouldBe` "A1836F6E658465696E73" it "packs () correct" $ - hex (pack ()) `shouldBe` "C0" + hex (pack' ()) `shouldBe` "C0" prepareData :: MonadFail m => ByteString -> m ByteString prepareData = (toStrict <$>) . unhex . fromStrict