servant-serialization 0.1.0 → 0.2.0
raw patch · 10 files changed
+330/−11 lines, 10 filesdep ~base
Dependency ranges changed: base
Files
- CHANGELOG.md +9/−0
- Doctests.hs +2/−2
- Main.hs +41/−3
- lib/Servant/API/ContentTypes/Binary.hs +46/−0
- lib/Servant/API/ContentTypes/Cereal.hs +50/−0
- lib/Servant/API/ContentTypes/Flat.hs +46/−0
- lib/Servant/API/ContentTypes/Persist.hs +51/−0
- lib/Servant/API/ContentTypes/SerialiseCBOR.hs +49/−0
- lib/Servant/API/ContentTypes/ShowRead.hs +21/−2
- servant-serialization.cabal +15/−4
+ CHANGELOG.md view
@@ -0,0 +1,9 @@+### 0.2.0++* Add changelog, cabal fields.+* Add support for packages: binary, cereal, serialise, flat, persist.+* Improve error messages.++### 0.1.0++* Initial release. Only support for Show/Read data.
Doctests.hs view
@@ -7,6 +7,6 @@ main = do args <- System.Environment.getArgs Test.DocTest.doctest- $ "./lib/"- : "./Main.hs"+ $ "./Main.hs"+ : "./lib/" : args
Main.hs view
@@ -10,15 +10,25 @@ import Data.Proxy (Proxy(..)) import GHC.Generics (Generic) import Network.Wai.Handler.Warp (run)-import qualified Data.Aeson as Aeson (ToJSON, FromJSON)+import qualified Data.Text as T import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL-import qualified Data.Text as T import qualified Web.FormUrlEncoded as UrlEncoded (ToForm, FromForm)+import qualified Data.Aeson as Aeson (ToJSON, FromJSON)+import qualified Data.Binary as Binary (Binary)+import qualified Data.Serialize as Cereal (Serialize)+import qualified Codec.Serialise as Serialise (Serialise)+import qualified Data.Persist as Persist (Persist)+import qualified Flat as Flat (Flat) import Servant.API import Servant.Server import Servant.API.ContentTypes.ShowRead+import Servant.API.ContentTypes.Binary+import Servant.API.ContentTypes.Cereal+import Servant.API.ContentTypes.SerialiseCBOR+import Servant.API.ContentTypes.Persist+import Servant.API.ContentTypes.Flat import Servant.Client import Network.HTTP.Client (Manager)@@ -36,6 +46,14 @@ instance Aeson.FromJSON Example instance Aeson.ToJSON Example +instance Binary.Binary Example+instance Cereal.Serialize Example+instance Serialise.Serialise Example+instance Persist.Persist Example+instance Flat.Flat Example++instance Flat.Flat Ordering+ type TestAPI a -- string types = "string" :> ReqBody '[PlainText] String :> Post '[PlainText] String@@ -46,7 +64,12 @@ :<|> "urlenc" :> ReqBody '[FormUrlEncoded] a :> Post '[FormUrlEncoded] a :<|> "json" :> ReqBody '[JSON] a :> Post '[JSON] a -- additional serialization- :<|> "show" :> ReqBody '[ShowRead] a :> Post '[ShowRead] a+ :<|> "showread" :> ReqBody '[ShowRead] a :> Post '[ShowRead] a+ :<|> "binary" :> ReqBody '[BinaryFmt] a :> Post '[BinaryFmt] a+ :<|> "cereal" :> ReqBody '[CerealFmt] a :> Post '[CerealFmt] a+ :<|> "cbor" :> ReqBody '[CBOR] a :> Post '[CBOR] a+ :<|> "persist" :> ReqBody '[PersistFmt] a :> Post '[PersistFmt] a+ :<|> "flat" :> ReqBody '[FlatFmt] a :> Post '[FlatFmt] a -- | Client functions rtString@@ -56,6 +79,11 @@ :<|> rtUrlEnc :<|> rtJson :<|> rtShow+ :<|> rtBinary+ :<|> rtCereal+ :<|> rtCBOR+ :<|> rtPersist+ :<|> rtFlat = client (Proxy @(TestAPI Example)) main :: IO ()@@ -69,6 +97,11 @@ :<|> return :<|> return :<|> return+ :<|> return+ :<|> return+ :<|> return+ :<|> return+ :<|> return -- $setup -- >>> import Control.Concurrent (forkIO)@@ -87,6 +120,11 @@ -- prop> \x -> QC.ioProperty $ testRoundTrip mgr rtUrlEnc (x :: Example) -- prop> \x -> QC.ioProperty $ testRoundTrip mgr rtJson (x :: Example) -- prop> \x -> QC.ioProperty $ testRoundTrip mgr rtShow (x :: Example)+-- prop> \x -> QC.ioProperty $ testRoundTrip mgr rtBinary (x :: Example)+-- prop> \x -> QC.ioProperty $ testRoundTrip mgr rtCereal (x :: Example)+-- prop> \x -> QC.ioProperty $ testRoundTrip mgr rtCBOR (x :: Example)+-- prop> \x -> QC.ioProperty $ testRoundTrip mgr rtPersist (x :: Example)+-- prop> \x -> QC.ioProperty $ testRoundTrip mgr rtFlat (x :: Example) testRoundTrip :: (Eq a, Show a) => Manager -> (a -> ClientM a) -> a -> IO Bool testRoundTrip mgr roundtrip val = do let env = mkClientEnv mgr $ BaseUrl Http "localhost" 80801 ""
+ lib/Servant/API/ContentTypes/Binary.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Servant.API.ContentTypes.Binary where++import Data.Proxy (Proxy(..))+import Network.HTTP.Media ((//))+import qualified Data.List.NonEmpty as NonEmpty++import Servant.API.ContentTypes+import Data.Binary++-- | Content-type for instances of the 'Binary' class in the package "binary".+-- Trailing garbage is ignored.+data BinaryFmt++-- | Mime-type using the word "hackage" and the name of the package "binary".+instance Accept BinaryFmt where+ contentTypes Proxy = NonEmpty.fromList+ [ "application" // "x-hackage-binary"+ , "application" // "vnd.hackage.binary"+ ]++-- |+--+-- >>> mimeRender (Proxy :: Proxy BinaryFmt) (3.14 :: Float)+-- "\NUL\NUL\200\245\195\255\255\255\255\255\255\255\234"+instance Binary a => MimeRender BinaryFmt a where+ mimeRender Proxy = encode++-- |+--+-- >>> let bsl = mimeRender (Proxy :: Proxy BinaryFmt) (3.14 :: Float)+-- >>> mimeUnrender (Proxy :: Proxy BinaryFmt) bsl :: Either String Float+-- Right 3.14+--+-- >>> mimeUnrender (Proxy :: Proxy BinaryFmt) (bsl <> "trailing garbage") :: Either String Float+-- Right 3.14+--+-- >>> mimeUnrender (Proxy :: Proxy BinaryFmt) ("preceding garbage" <> bsl) :: Either String Float+-- Left "Data.Binary.decodeOrFail: not enough bytes at byte-offset 30"+instance Binary a => MimeUnrender BinaryFmt a where+ mimeUnrender Proxy bsl =+ case decodeOrFail bsl of+ Left (_unconsumedInput, consumedByteCt, err) -> Left $ "Data.Binary.decodeOrFail: " ++ err ++ " at byte-offset " ++ show consumedByteCt+ Right (_unconsumedInput, _consumedByteCt, val) -> Right val
+ lib/Servant/API/ContentTypes/Cereal.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Servant.API.ContentTypes.Cereal where++import Data.Proxy (Proxy(..))+import Network.HTTP.Media ((//))+import qualified Data.List.NonEmpty as NonEmpty++import Servant.API.ContentTypes+import Data.Serialize++-- | Content-type for instances of the 'Serialize' class in the package+-- "cereal". Trailing garbage is ignored.+data CerealFmt++-- | Mime-type using the word "hackage" and the name of the package "cereal".+instance Accept CerealFmt where+ contentTypes Proxy = NonEmpty.fromList+ [ "application" // "x-hackage-cereal"+ , "application" // "vnd.hackage.cereal"+ ]++-- |+--+-- >>> mimeRender (Proxy :: Proxy CerealFmt) (3.14 :: Float)+-- "@H\245\195"+instance Serialize a => MimeRender CerealFmt a where+ mimeRender Proxy = encodeLazy++-- |+--+-- >>> let bsl = mimeRender (Proxy :: Proxy CerealFmt) (3.14 :: Float)+-- >>> mimeUnrender (Proxy :: Proxy CerealFmt) bsl :: Either String Float+-- Right 3.14+--+-- >>> mimeUnrender (Proxy :: Proxy CerealFmt) (bsl <> "trailing garbage") :: Either String Float+-- Right 3.14+--+-- Cereal doesn't detect this preceding garbage.+--+-- >>> mimeUnrender (Proxy :: Proxy CerealFmt) ("preceding garbage" <> bsl) :: Either String Float+-- Right ...+--+-- >>> mimeUnrender (Proxy :: Proxy CerealFmt) "garbage" :: Either String (Float, Float)+-- Left "Data.Serialize.decodeLazy: too few bytes\nFrom:\tdemandInput\n\n"+instance Serialize a => MimeUnrender CerealFmt a where+ mimeUnrender Proxy = mapLeft ("Data.Serialize.decodeLazy: " ++) . decodeLazy+ where+ mapLeft f = either (Left . f) Right
+ lib/Servant/API/ContentTypes/Flat.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Servant.API.ContentTypes.Flat where++import Data.Proxy (Proxy(..))+import Network.HTTP.Media ((//))+import qualified Data.List.NonEmpty as NonEmpty++import Servant.API.ContentTypes+import Flat++-- | Content-type for instances of the 'Flat' class in the package+-- "flat".+data FlatFmt++-- | Mime-type using the word "hackage" and the name of the package "flat".+instance Accept FlatFmt where+ contentTypes Proxy = NonEmpty.fromList+ [ "application" // "x-hackage-flat"+ , "application" // "vnd.hackage.flat"+ ]++-- |+--+-- >>> mimeRender (Proxy :: Proxy FlatFmt) (3.14 :: Float)+-- "@H\245\195"+instance Flat a => MimeRender FlatFmt a where+ mimeRender Proxy = flatRaw++-- |+--+-- >>> let bsl = mimeRender (Proxy :: Proxy FlatFmt) (3.14 :: Float)+-- >>> mimeUnrender (Proxy :: Proxy FlatFmt) bsl :: Either String Float+-- Right 3.14+--+-- >>> mimeUnrender (Proxy :: Proxy FlatFmt) (bsl <> "trailing garbage") :: Either String Float+-- Left "Flat.unflatRaw: TooMuchSpace (0x...,S {currPtr = 0x..., usedBits = 0})"+--+-- >>> mimeUnrender (Proxy :: Proxy FlatFmt) ("preceding garbage" <> bsl) :: Either String Float+-- Left "Flat.unflatRaw: TooMuchSpace (0x...,S {currPtr = 0x..., usedBits = 0})"+instance Flat a => MimeUnrender FlatFmt a where+ mimeUnrender Proxy = mapLeft prettyErr . unflatRaw+ where+ mapLeft f = either (Left . f) Right+ prettyErr err = "Flat.unflatRaw: " ++ show err
+ lib/Servant/API/ContentTypes/Persist.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Servant.API.ContentTypes.Persist where++import Data.Proxy (Proxy(..))+import Network.HTTP.Media ((//))+import qualified Data.List.NonEmpty as NonEmpty++import Servant.API.ContentTypes+import Data.Persist+import qualified Data.ByteString.Lazy as BSL (toStrict, fromStrict)++-- | Content-type for instances of the 'Persist' class in the package+-- "persist". Trailing garbage is ignored.+data PersistFmt++-- | Mime-type using the word "hackage" and the name of the package "persist".+instance Accept PersistFmt where+ contentTypes Proxy = NonEmpty.fromList+ [ "application" // "x-hackage-persist"+ , "application" // "vnd.hackage.persist"+ ]++-- |+--+-- >>> mimeRender (Proxy :: Proxy PersistFmt) (3.14 :: Float)+-- "\195\245H@"+instance Persist a => MimeRender PersistFmt a where+ mimeRender Proxy = BSL.fromStrict . encode++-- |+--+-- >>> let bsl = mimeRender (Proxy :: Proxy PersistFmt) (3.14 :: Float)+-- >>> mimeUnrender (Proxy :: Proxy PersistFmt) bsl :: Either String Float+-- Right 3.14+--+-- >>> mimeUnrender (Proxy :: Proxy PersistFmt) (bsl <> "trailing garbage") :: Either String Float+-- Right 3.14+--+-- Persist doesn't detect this preceding garbage.+--+-- >>> mimeUnrender (Proxy :: Proxy PersistFmt) ("preceding garbage" <> bsl) :: Either String Float+-- Right ...+--+-- >>> mimeUnrender (Proxy :: Proxy PersistFmt) "garbage" :: Either String (Float, Float)+-- Left "Data.Persist.decode: LengthException 4 \"Not enough bytes available\""+instance Persist a => MimeUnrender PersistFmt a where+ mimeUnrender Proxy = mapLeft ("Data.Persist.decode: " ++) . decode . BSL.toStrict+ where+ mapLeft f = either (Left . f) Right
+ lib/Servant/API/ContentTypes/SerialiseCBOR.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Servant.API.ContentTypes.SerialiseCBOR where++import Data.Proxy (Proxy(..))+import Network.HTTP.Media ((//))+import qualified Data.List.NonEmpty as NonEmpty++import Servant.API.ContentTypes+import Codec.Serialise++-- | Content-type for instances of the 'Serialise' class in the package+-- "serialise". Trailing garbage is ignored.+data CBOR++-- | Mime-type for CBOR and additional ones using the word "hackage" and the+-- name of the package "serialise".+instance Accept CBOR where+ contentTypes Proxy = NonEmpty.fromList+ [ "application" // "cbor"+ , "application" // "x-hackage-binary"+ , "application" // "vnd.hackage.binary"+ ]++-- |+--+-- >>> mimeRender (Proxy :: Proxy CBOR) (3.14 :: Float)+-- "\250@H\245\195"+instance Serialise a => MimeRender CBOR a where+ mimeRender Proxy = serialise++-- |+--+-- >>> let bsl = mimeRender (Proxy :: Proxy CBOR) (3.14 :: Float)+-- >>> mimeUnrender (Proxy :: Proxy CBOR) bsl :: Either String Float+-- Right 3.14+--+-- >>> mimeUnrender (Proxy :: Proxy CBOR) (bsl <> "trailing garbage") :: Either String Float+-- Right 3.14+--+-- >>> mimeUnrender (Proxy :: Proxy CBOR) ("preceding garbage" <> bsl) :: Either String Float+-- Left "Codec.Serialise.deserialiseOrFail: expected float at byte-offset 0"+instance Serialise a => MimeUnrender CBOR a where+ mimeUnrender Proxy = mapLeft prettyErr . deserialiseOrFail+ where+ mapLeft f = either (Left . f) Right+ prettyErr (DeserialiseFailure offset err) =+ "Codec.Serialise.deserialiseOrFail: " ++ err ++ " at byte-offset " ++ show offset
lib/Servant/API/ContentTypes/ShowRead.hs view
@@ -10,13 +10,16 @@ import Control.Monad ((<=<)) import Data.Text.Lazy (pack, unpack) import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8')+import Data.Text.Encoding.Error (UnicodeException(..)) import Text.Read (readEither) import Servant.API.ContentTypes --- | Content type for UTF-8 encoded Show/Read data.+-- | Content-type for instances of the 'Show' and 'Read' classes encoded as+-- UTF-8 data. This is probably slow. data ShowRead +-- | Mime-type using the phrases "haskell" and "showread". instance Accept ShowRead where contentTypes Proxy = NonEmpty.fromList [ "application" // "x-haskell-showread"@@ -26,7 +29,23 @@ instance Show a => MimeRender ShowRead a where mimeRender Proxy = encodeUtf8 . pack . show +-- $setup+-- >>> :set -XOverloadedStrings++-- | Decode UTF-8 data and then with 'Read' instance.+--+-- >>> mimeUnrender (Proxy :: Proxy ShowRead) "1e5" :: Either String Double+-- Right 100000.0+--+-- >>> mimeUnrender (Proxy :: Proxy ShowRead) "hello" :: Either String Double+-- Left "Prelude.read: no parse"+--+-- >>> mimeUnrender (Proxy :: Proxy ShowRead) "hello\xc3\x28" :: Either String Double+-- Left "Data.Text.Internal.Encoding.streamDecodeUtf8With: Invalid UTF-8 stream: invalid byte-value: 195" instance Read a => MimeUnrender ShowRead a where- mimeUnrender Proxy = readEither . unpack <=< mapLeft show . decodeUtf8'+ mimeUnrender Proxy = readEither . unpack <=< mapLeft prettyErr . decodeUtf8' where mapLeft f = either (Left . f) Right+ prettyErr (DecodeError err byteVal) =+ err ++ maybe "" ((": invalid byte-value: " ++) . show) byteVal+ prettyErr _ = "unknown error" -- TODO: when 'text' removes deprecated 'EncodeError' constructor, remove this case
servant-serialization.cabal view
@@ -5,13 +5,22 @@ -- see: https://github.com/sol/hpack name: servant-serialization-version: 0.1.0+version: 0.2.0 description: Servant content types and instances for common serialization formats.+category: Serialization, Servant+maintainer: plredmond license: MIT build-type: Simple+extra-source-files:+ CHANGELOG.md library exposed-modules:+ Servant.API.ContentTypes.Binary+ Servant.API.ContentTypes.Cereal+ Servant.API.ContentTypes.Flat+ Servant.API.ContentTypes.Persist+ Servant.API.ContentTypes.SerialiseCBOR Servant.API.ContentTypes.ShowRead other-modules: Paths_servant_serialization@@ -19,8 +28,9 @@ lib ghc-options: -Wall build-depends:- base ==4.15.*+ base >=4.15 && <4.17 , binary+ , bytestring , cereal , flat , http-media@@ -38,7 +48,7 @@ build-depends: QuickCheck , aeson- , base ==4.15.*+ , base >=4.15 && <4.17 , binary , bytestring , cereal@@ -64,8 +74,9 @@ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: QuickCheck- , base ==4.15.*+ , base >=4.15 && <4.17 , binary+ , bytestring , cereal , doctest , flat