diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/Doctests.hs b/Doctests.hs --- a/Doctests.hs +++ b/Doctests.hs @@ -7,6 +7,6 @@ main = do args <- System.Environment.getArgs Test.DocTest.doctest - $ "./lib/" - : "./Main.hs" + $ "./Main.hs" + : "./lib/" : args diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 "" diff --git a/lib/Servant/API/ContentTypes/Binary.hs b/lib/Servant/API/ContentTypes/Binary.hs new file mode 100644 --- /dev/null +++ b/lib/Servant/API/ContentTypes/Binary.hs @@ -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 diff --git a/lib/Servant/API/ContentTypes/Cereal.hs b/lib/Servant/API/ContentTypes/Cereal.hs new file mode 100644 --- /dev/null +++ b/lib/Servant/API/ContentTypes/Cereal.hs @@ -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 diff --git a/lib/Servant/API/ContentTypes/Flat.hs b/lib/Servant/API/ContentTypes/Flat.hs new file mode 100644 --- /dev/null +++ b/lib/Servant/API/ContentTypes/Flat.hs @@ -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 diff --git a/lib/Servant/API/ContentTypes/Persist.hs b/lib/Servant/API/ContentTypes/Persist.hs new file mode 100644 --- /dev/null +++ b/lib/Servant/API/ContentTypes/Persist.hs @@ -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 diff --git a/lib/Servant/API/ContentTypes/SerialiseCBOR.hs b/lib/Servant/API/ContentTypes/SerialiseCBOR.hs new file mode 100644 --- /dev/null +++ b/lib/Servant/API/ContentTypes/SerialiseCBOR.hs @@ -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 diff --git a/lib/Servant/API/ContentTypes/ShowRead.hs b/lib/Servant/API/ContentTypes/ShowRead.hs --- a/lib/Servant/API/ContentTypes/ShowRead.hs +++ b/lib/Servant/API/ContentTypes/ShowRead.hs @@ -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 diff --git a/servant-serialization.cabal b/servant-serialization.cabal --- a/servant-serialization.cabal +++ b/servant-serialization.cabal @@ -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