Merge pull request #13 from anchor/form-urlencoded

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

servant.cabal

@@ -94,3 +94,4 @@ test-suite spec
     , servant
     , string-conversions
     , text
+    , url

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,48 @@ 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, "") = escape k
+        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
+                                )
+                [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 "+"
+    mapM parsePair xs

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 ()
@@ -38,6 +40,20 @@ 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)])
+
+        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