From 1d378e644c41df455fb2fcd087393dbd25e747a5 Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Sat, 21 Feb 2015 07:44:28 +1100 Subject: [PATCH 1/2] Add support for application/x-www-form-urlencoded --- src/Servant/API/ContentTypes.hs | 63 +++++++++++++++++++++++++++- test/Servant/API/ContentTypesSpec.hs | 6 +++ 2 files changed, 68 insertions(+), 1 deletion(-) diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs index 249756c3..2c71503d 100644 --- a/src/Servant/API/ContentTypes.hs +++ b/src/Servant/API/ContentTypes.hs @@ -12,11 +12,14 @@ module Servant.API.ContentTypes where import Control.Arrow (left) +import Control.Monad import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode) import qualified Data.ByteString as BS import Data.ByteString.Lazy (ByteString, fromStrict, toStrict) +import qualified Data.ByteString.Lazy as B import Data.String.Conversions (cs) +import Data.Monoid import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy.Encoding as TextL import qualified Data.Text as TextS @@ -24,10 +27,13 @@ import qualified Data.Text.Encoding as TextS import Data.Typeable import GHC.Exts (Constraint) import qualified Network.HTTP.Media as M +import Network.URI (unEscapeString, escapeURIString, + isUnreserved) -- * Provided content types data JSON deriving Typeable data PlainText deriving Typeable +data FormUrlEncoded deriving Typeable data OctetStream deriving Typeable -- * Accept class @@ -48,6 +54,10 @@ class Accept ctype where instance Accept JSON where contentType _ = "application" M.// "json" +-- | @application/x-www-form-urlencoded@ +instance Accept FormUrlEncoded where + contentType _ = "application" M.// "x-www-form-urlencoded" + -- | @text/plain;charset=utf-8@ instance Accept PlainText where contentType _ = "text" M.// "plain" M./: ("charset", "utf-8") @@ -179,6 +189,10 @@ type family IsNonEmpty (ls::[*]) :: Constraint where instance ToJSON a => MimeRender JSON a where toByteString _ = encode +-- | `encodeFormUrlEncoded . toFormUrlEncoded` +instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where + toByteString _ = encodeFormUrlEncoded . toFormUrlEncoded + -- | `TextL.encodeUtf8` instance MimeRender PlainText TextL.Text where toByteString _ = TextL.encodeUtf8 @@ -191,7 +205,7 @@ instance MimeRender PlainText TextS.Text where instance MimeRender OctetStream ByteString where toByteString _ = id --- | `toStrict` +-- | `fromStrict` instance MimeRender OctetStream BS.ByteString where toByteString _ = fromStrict @@ -203,6 +217,10 @@ instance MimeRender OctetStream BS.ByteString where instance FromJSON a => MimeUnrender JSON a where fromByteString _ = eitherDecode +-- | `decodeFormUrlEncoded >=> fromFormUrlEncoded` +instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where + fromByteString _ = decodeFormUrlEncoded >=> fromFormUrlEncoded + -- | `left show . TextL.decodeUtf8'` instance MimeUnrender PlainText TextL.Text where fromByteString _ = left show . TextL.decodeUtf8' @@ -218,3 +236,46 @@ instance MimeUnrender OctetStream ByteString where -- | `Right . toStrict` instance MimeUnrender OctetStream BS.ByteString where fromByteString _ = Right . toStrict + + +-------------------------------------------------------------------------- +-- * FormUrlEncoded + +-- | A type that can be converted to @application/x-www-form-urlencoded@ +class ToFormUrlEncoded a where + toFormUrlEncoded :: a -> [(TextS.Text, TextS.Text)] + +instance ToFormUrlEncoded [(TextS.Text, TextS.Text)] where + toFormUrlEncoded = id + +-- | A type that can be converted from @application/x-www-form-urlencoded@, +-- with the possibility of failure. +class FromFormUrlEncoded a where + fromFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> Either String a + +instance FromFormUrlEncoded [(TextS.Text, TextS.Text)] where + fromFormUrlEncoded = return + +encodeFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> ByteString +encodeFormUrlEncoded xs = + let escape :: TextS.Text -> ByteString + escape = cs . escapeURIString isUnreserved . cs + encodePair :: (TextS.Text, TextS.Text) -> ByteString + encodePair (k, v) = escape k <> "=" <> escape v + in B.intercalate "&" $ map encodePair xs + +decodeFormUrlEncoded :: ByteString -> Either String [(TextS.Text, TextS.Text)] +decodeFormUrlEncoded "" = return [] +decodeFormUrlEncoded q = do + let xs :: [TextS.Text] + xs = TextS.splitOn "&" . cs $ q + parsePair :: TextS.Text -> Either String (TextS.Text, TextS.Text) + parsePair p = + case TextS.splitOn "=" p of + [k,v] -> return ( unescape k + , unescape v + ) + _ -> Left $ "not a valid pair: " <> cs p + unescape :: TextS.Text -> TextS.Text + unescape = cs . unEscapeString . cs . TextS.intercalate "%20" . TextS.splitOn "+" + mapM parsePair xs diff --git a/test/Servant/API/ContentTypesSpec.hs b/test/Servant/API/ContentTypesSpec.hs index b2133ff7..6e09464d 100644 --- a/test/Servant/API/ContentTypesSpec.hs +++ b/test/Servant/API/ContentTypesSpec.hs @@ -38,6 +38,12 @@ spec = describe "Servant.API.ContentTypes" $ do let p = Proxy :: Proxy JSON property $ \x -> fromByteString p (toByteString p x) == Right (x::SomeData) + describe "The FormUrlEncoded Content-Type type" $ do + + it "has fromByteString reverse toByteString" $ do + let p = Proxy :: Proxy FormUrlEncoded + property $ \x -> fromByteString p (toByteString p x) == Right (x::[(TextS.Text,TextS.Text)]) + describe "The PlainText Content-Type type" $ do it "has fromByteString reverse toByteString (lazy Text)" $ do From 4f91a28d57a83fc660a0883754bb477f19847cf5 Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Mon, 23 Feb 2015 16:54:10 +1100 Subject: [PATCH 2/2] Add test for FormUrlEncoded using Network.URL --- servant.cabal | 1 + src/Servant/API/ContentTypes.hs | 2 ++ test/Servant/API/ContentTypesSpec.hs | 12 +++++++++++- 3 files changed, 14 insertions(+), 1 deletion(-) diff --git a/servant.cabal b/servant.cabal index f52ca766..a967e10a 100644 --- a/servant.cabal +++ b/servant.cabal @@ -94,3 +94,4 @@ test-suite spec , servant , string-conversions , text + , url diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs index 2c71503d..f2ae6b15 100644 --- a/src/Servant/API/ContentTypes.hs +++ b/src/Servant/API/ContentTypes.hs @@ -261,6 +261,7 @@ encodeFormUrlEncoded xs = let escape :: TextS.Text -> ByteString escape = cs . escapeURIString isUnreserved . cs encodePair :: (TextS.Text, TextS.Text) -> ByteString + encodePair (k, "") = escape k encodePair (k, v) = escape k <> "=" <> escape v in B.intercalate "&" $ map encodePair xs @@ -275,6 +276,7 @@ decodeFormUrlEncoded q = do [k,v] -> return ( unescape k , unescape v ) + [k] -> return ( unescape k, "" ) _ -> Left $ "not a valid pair: " <> cs p unescape :: TextS.Text -> TextS.Text unescape = cs . unEscapeString . cs . TextS.intercalate "%20" . TextS.splitOn "+" diff --git a/test/Servant/API/ContentTypesSpec.hs b/test/Servant/API/ContentTypesSpec.hs index 6e09464d..49b879dc 100644 --- a/test/Servant/API/ContentTypesSpec.hs +++ b/test/Servant/API/ContentTypesSpec.hs @@ -6,11 +6,12 @@ module Servant.API.ContentTypesSpec where import Control.Applicative +import Control.Arrow import Data.Aeson import Data.Function (on) import Data.Proxy -import Data.ByteString.Char8 +import Data.ByteString.Char8 (ByteString, append, pack) import qualified Data.ByteString.Lazy as BSL import Data.List (maximumBy) import Data.Maybe (fromJust, isJust, isNothing) @@ -19,6 +20,7 @@ import Data.String.Conversions (cs) import qualified Data.Text as TextS import qualified Data.Text.Lazy as TextL import GHC.Generics +import Network.URL (importParams, exportParams) import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Instances () @@ -44,6 +46,14 @@ spec = describe "Servant.API.ContentTypes" $ do let p = Proxy :: Proxy FormUrlEncoded property $ \x -> fromByteString p (toByteString p x) == Right (x::[(TextS.Text,TextS.Text)]) + it "has fromByteString reverse exportParams (Network.URL)" $ do + let p = Proxy :: Proxy FormUrlEncoded + property $ \x -> (fromByteString p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)]) + + it "has importParams (Network.URL) reverse toByteString" $ do + let p = Proxy :: Proxy FormUrlEncoded + property $ \x -> (fmap (map (cs *** cs)) . importParams . cs . toByteString p $ x) == Just (x::[(TextS.Text,TextS.Text)]) + describe "The PlainText Content-Type type" $ do it "has fromByteString reverse toByteString (lazy Text)" $ do