@@ -12,11 +12,14 @@
12module Servant.API.ContentTypes where
12module Servant.API.ContentTypes where
14import Control.Arrow (left)
14import Control.Arrow (left)
15import Data.Aeson (FromJSON, ToJSON, eitherDecode,
16import Data.Aeson (FromJSON, ToJSON, eitherDecode,
17import qualified Data.ByteString as BS
18import qualified Data.ByteString as BS
18import Data.ByteString.Lazy (ByteString, fromStrict, toStrict)
19import Data.ByteString.Lazy (ByteString, fromStrict, toStrict)
20+import qualified Data.ByteString.Lazy as B
19import Data.String.Conversions (cs)
21import Data.String.Conversions (cs)
20import qualified Data.Text.Lazy as TextL
23import qualified Data.Text.Lazy as TextL
21import qualified Data.Text.Lazy.Encoding as TextL
24import qualified Data.Text.Lazy.Encoding as TextL
22import qualified Data.Text as TextS
25import qualified Data.Text as TextS
@@ -24,10 +27,13 @@ import qualified Data.Text.Encoding as TextS
24import Data.Typeable
27import Data.Typeable
25import GHC.Exts (Constraint)
28import GHC.Exts (Constraint)
26import qualified Network.HTTP.Media as M
29import qualified Network.HTTP.Media as M
30+import Network.URI (unEscapeString, escapeURIString,
28-- * Provided content types
33-- * Provided content types
29data JSON deriving Typeable
34data JSON deriving Typeable
30data PlainText deriving Typeable
35data PlainText deriving Typeable
36+data FormUrlEncoded deriving Typeable
31data OctetStream deriving Typeable
37data OctetStream deriving Typeable
33-- * Accept class
39-- * Accept class
@@ -48,6 +54,10 @@ class Accept ctype where
48instance Accept JSON where
54instance Accept JSON where
49 contentType _ = "application" M.// "json"
55 contentType _ = "application" M.// "json"
57+-- | @application/x-www-form-urlencoded@
58+instance Accept FormUrlEncoded where
59+ contentType _ = "application" M.// "x-www-form-urlencoded"
51-- | @text/plain;charset=utf-8@
61-- | @text/plain;charset=utf-8@
52instance Accept PlainText where
62instance Accept PlainText where
53 contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
63 contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
@@ -179,6 +189,10 @@ type family IsNonEmpty (ls::[*]) :: Constraint where
179instance ToJSON a => MimeRender JSON a where
189instance ToJSON a => MimeRender JSON a where
180 toByteString _ = encode
190 toByteString _ = encode
192+-- | `encodeFormUrlEncoded . toFormUrlEncoded`
193+instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
194+ toByteString _ = encodeFormUrlEncoded . toFormUrlEncoded
182-- | `TextL.encodeUtf8`
196-- | `TextL.encodeUtf8`
183instance MimeRender PlainText TextL.Text where
197instance MimeRender PlainText TextL.Text where
184 toByteString _ = TextL.encodeUtf8
198 toByteString _ = TextL.encodeUtf8
@@ -191,7 +205,7 @@ instance MimeRender PlainText TextS.Text where
191instance MimeRender OctetStream ByteString where
205instance MimeRender OctetStream ByteString where
192 toByteString _ = id
206 toByteString _ = id
194−-- | `toStrict`
208+-- | `fromStrict`
195instance MimeRender OctetStream BS.ByteString where
209instance MimeRender OctetStream BS.ByteString where
196 toByteString _ = fromStrict
210 toByteString _ = fromStrict
@@ -203,6 +217,10 @@ instance MimeRender OctetStream BS.ByteString where
203instance FromJSON a => MimeUnrender JSON a where
217instance FromJSON a => MimeUnrender JSON a where
204 fromByteString _ = eitherDecode
218 fromByteString _ = eitherDecode
220+-- | `decodeFormUrlEncoded >=> fromFormUrlEncoded`
221+instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where
222+ fromByteString _ = decodeFormUrlEncoded >=> fromFormUrlEncoded
206-- | `left show . TextL.decodeUtf8'`
224-- | `left show . TextL.decodeUtf8'`
207instance MimeUnrender PlainText TextL.Text where
225instance MimeUnrender PlainText TextL.Text where
208 fromByteString _ = left show . TextL.decodeUtf8'
226 fromByteString _ = left show . TextL.decodeUtf8'
@@ -218,3 +236,46 @@ instance MimeUnrender OctetStream ByteString where
218-- | `Right . toStrict`
236-- | `Right . toStrict`
219instance MimeUnrender OctetStream BS.ByteString where
237instance MimeUnrender OctetStream BS.ByteString where
220 fromByteString _ = Right . toStrict
238 fromByteString _ = Right . toStrict
241+--------------------------------------------------------------------------
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)]
248+instance ToFormUrlEncoded [(TextS.Text, TextS.Text)] where
249+ toFormUrlEncoded = id
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
256+instance FromFormUrlEncoded [(TextS.Text, TextS.Text)] where
257+ fromFormUrlEncoded = return
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, v) = escape k <> "=" <> escape v
265+ in B.intercalate "&" $ map encodePair xs
267+decodeFormUrlEncoded :: ByteString -> Either String [(TextS.Text, TextS.Text)]
268+decodeFormUrlEncoded "" = return []
269+decodeFormUrlEncoded q = do
270+ let xs :: [TextS.Text]
271+ xs = TextS.splitOn "&" . cs $ q
272+ parsePair :: TextS.Text -> Either String (TextS.Text, TextS.Text)
274+ case TextS.splitOn "=" p of
275+ [k,v] -> return ( unescape k
278+ _ -> Left $ "not a valid pair: " <> cs p
279+ unescape :: TextS.Text -> TextS.Text
280+ unescape = cs . unEscapeString . cs . TextS.intercalate "%20" . TextS.splitOn "+"