@@ -12,11 +12,14 @@
1212module Servant.API.ContentTypes where
1313
1414import Control.Arrow (left)
15+import Control.Monad
1516import Data.Aeson (FromJSON, ToJSON, eitherDecode,
1617 encode)
1718import qualified Data.ByteString as BS
1819import Data.ByteString.Lazy (ByteString, fromStrict, toStrict)
20+import qualified Data.ByteString.Lazy as B
1921import Data.String.Conversions (cs)
22+import Data.Monoid
2023import qualified Data.Text.Lazy as TextL
2124import qualified Data.Text.Lazy.Encoding as TextL
2225import qualified Data.Text as TextS
@@ -24,10 +27,13 @@ import qualified Data.Text.Encoding as TextS
2427import Data.Typeable
2528import GHC.Exts (Constraint)
2629import qualified Network.HTTP.Media as M
30+import Network.URI (unEscapeString, escapeURIString,
31+ isUnreserved)
2732
2833-- * Provided content types
2934data JSON deriving Typeable
3035data PlainText deriving Typeable
36+data FormUrlEncoded deriving Typeable
3137data OctetStream deriving Typeable
3238
3339-- * Accept class
@@ -48,6 +54,10 @@ class Accept ctype where
4854instance Accept JSON where
4955 contentType _ = "application" M.// "json"
5056
57+-- | @application/x-www-form-urlencoded@
58+instance Accept FormUrlEncoded where
59+ contentType _ = "application" M.// "x-www-form-urlencoded"
60+
5161-- | @text/plain;charset=utf-8@
5262instance Accept PlainText where
5363 contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
@@ -179,6 +189,10 @@ type family IsNonEmpty (ls::[*]) :: Constraint where
179189instance ToJSON a => MimeRender JSON a where
180190 toByteString _ = encode
181191
192+-- | `encodeFormUrlEncoded . toFormUrlEncoded`
193+instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
194+ toByteString _ = encodeFormUrlEncoded . toFormUrlEncoded
195+
182196-- | `TextL.encodeUtf8`
183197instance MimeRender PlainText TextL.Text where
184198 toByteString _ = TextL.encodeUtf8
@@ -191,7 +205,7 @@ instance MimeRender PlainText TextS.Text where
191205instance MimeRender OctetStream ByteString where
192206 toByteString _ = id
193207
194−-- | `toStrict`
208+-- | `fromStrict`
195209instance MimeRender OctetStream BS.ByteString where
196210 toByteString _ = fromStrict
197211
@@ -203,6 +217,10 @@ instance MimeRender OctetStream BS.ByteString where
203217instance FromJSON a => MimeUnrender JSON a where
204218 fromByteString _ = eitherDecode
205219
220+-- | `decodeFormUrlEncoded >=> fromFormUrlEncoded`
221+instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where
222+ fromByteString _ = decodeFormUrlEncoded >=> fromFormUrlEncoded
223+
206224-- | `left show . TextL.decodeUtf8'`
207225instance MimeUnrender PlainText TextL.Text where
208226 fromByteString _ = left show . TextL.decodeUtf8'
@@ -218,3 +236,48 @@ instance MimeUnrender OctetStream ByteString where
218236-- | `Right . toStrict`
219237instance MimeUnrender OctetStream BS.ByteString where
220238 fromByteString _ = Right . toStrict
239+
240+
241+--------------------------------------------------------------------------
242+-- * FormUrlEncoded
243+
244+-- | A type that can be converted to @application/x-www-form-urlencoded@
245+class ToFormUrlEncoded a where
246+ toFormUrlEncoded :: a -> [(TextS.Text, TextS.Text)]
247+
248+instance ToFormUrlEncoded [(TextS.Text, TextS.Text)] where
249+ toFormUrlEncoded = id
250+
251+-- | A type that can be converted from @application/x-www-form-urlencoded@,
252+-- with the possibility of failure.
253+class FromFormUrlEncoded a where
254+ fromFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> Either String a
255+
256+instance FromFormUrlEncoded [(TextS.Text, TextS.Text)] where
257+ fromFormUrlEncoded = return
258+
259+encodeFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> ByteString
260+encodeFormUrlEncoded xs =
261+ let escape :: TextS.Text -> ByteString
262+ escape = cs . escapeURIString isUnreserved . cs
263+ encodePair :: (TextS.Text, TextS.Text) -> ByteString
264+ encodePair (k, "") = escape k
265+ encodePair (k, v) = escape k <> "=" <> escape v
266+ in B.intercalate "&" $ map encodePair xs
267+
268+decodeFormUrlEncoded :: ByteString -> Either String [(TextS.Text, TextS.Text)]
269+decodeFormUrlEncoded "" = return []
270+decodeFormUrlEncoded q = do
271+ let xs :: [TextS.Text]
272+ xs = TextS.splitOn "&" . cs $ q
273+ parsePair :: TextS.Text -> Either String (TextS.Text, TextS.Text)
274+ parsePair p =
275+ case TextS.splitOn "=" p of
276+ [k,v] -> return ( unescape k
277+ , unescape v
278+ )
279+ [k] -> return ( unescape k, "" )
280+ _ -> Left $ "not a valid pair: " <> cs p
281+ unescape :: TextS.Text -> TextS.Text
282+ unescape = cs . unEscapeString . cs . TextS.intercalate "%20" . TextS.splitOn "+"
283+ mapM parsePair xs