Add support for application/x-www-form-urlencoded

src/Servant/API/ContentTypes.hs

@@ -12,22 +12,28 @@
 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
 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

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