@@ -0,0 +1,158 @@
1+{-# LANGUAGE DefaultSignatures #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeOperators #-}
12+module Web.HttpApiData.Internal.FormUrlEncoded where
13+
14+import Control.Arrow (first, left, second)
15+import Control.Monad.State
16+import qualified Data.ByteString.Lazy as BSL
17+import qualified Data.Map as M
18+import Data.Monoid
19+import Data.String.Conversions (cs)
20+import qualified Data.Text as T
21+import GHC.Exts (IsList (..))
22+import GHC.Generics
23+import Network.URI (escapeURIString, isUnreserved,
24+ unEscapeString)
25+
26+import Web.HttpApiData.Internal.HttpApiData
27+
28+-- | The contents of a form, not yet url-encoded.
29+newtype Form = Form { unForm :: M.Map T.Text T.Text }
30+ deriving (Eq, Show, Read, Generic, Monoid)
31+
32+instance IsList Form where
33+ type Item Form = (T.Text, T.Text)
34+ fromList = Form . fromList
35+ toList = toList . unForm
36+
37+-- | A type that can be converted to @application/x-www-form-urlencoded@
38+class ToForm a where
39+ toForm :: a -> Form
40+ default toForm :: (Generic a, GToForm (Rep a)) => a -> Form
41+ toForm = genericToForm
42+
43+instance ToForm [(T.Text, T.Text)] where toForm = Form . M.fromList
44+instance ToForm (M.Map T.Text T.Text) where toForm = Form
45+instance ToForm Form where toForm = id
46+
47+genericToForm :: (Generic a, GToForm (Rep a)) => a -> Form
48+genericToForm x = evalState (unGenericToFormS . gToForm $ from x) (Nothing, 0)
49+
50+-- | A datatype for generically generating forms. The state keeps track of the
51+-- record name currently being inspected (if any) and the field number.
52+newtype GenericToFormS a = GenericToFormS {
53+ unGenericToFormS :: State (Maybe T.Text, Int) a
54+ } deriving (Functor, Applicative, Generic, Monad, MonadState (Maybe T.Text, Int))
55+
56+class GToForm (f :: * -> *) where
57+ gToForm :: f x -> GenericToFormS Form
58+
59+instance (GToForm f, GToForm g) => GToForm (f :*: g) where
60+ gToForm (a :*: b) = do
61+ a' <- gToForm a
62+ modify $ second (+ 1)
63+ b' <- gToForm b
64+ return (a' <> b')
65+
66+instance (GToForm f, GToForm g) => GToForm (f :+: g) where
67+ gToForm (L1 a) = gToForm a
68+ gToForm (R1 a) = gToForm a
69+
70+instance (GToForm f) => GToForm (M1 D x f) where
71+ gToForm (M1 a) = gToForm a
72+
73+instance (GToForm f) => GToForm (M1 C x f) where
74+ gToForm (M1 a) = gToForm a
75+
76+instance {-# OVERLAPPABLE #-} (Selector sel, GToForm f)
77+ => GToForm (M1 S sel f) where
78+ gToForm (M1 a) = modify (first $ const sel) >> gToForm a
79+ where sel = Just . T.pack $ selName (Proxy3 :: Proxy3 sel g p)
80+
81+instance (ToHttpApiData f) => GToForm (K1 i f) where
82+ gToForm (K1 a) = do
83+ s <- get
84+ return . Form $ M.insert (name s) (toUrlPiece a) $ mempty
85+ where name (Nothing, i) = T.pack $ show i
86+ name (Just x, _) = x
87+
88+-- | A type that can be converted from @application/x-www-form-urlencoded@,
89+-- with the possibility of failure.
90+class FromForm a where
91+ fromForm :: Form -> Either String a
92+ default fromForm :: (Generic a, GFromForm (Rep a))
93+ => Form -> Either String a
94+ fromForm = genericFromForm
95+
96+instance FromForm Form where fromForm = return
97+instance FromForm [(T.Text, T.Text)] where fromForm = return . M.toList . unForm
98+instance FromForm (M.Map T.Text T.Text) where fromForm = return . unForm
99+
100+genericFromForm :: (Generic a, GFromForm (Rep a))
101+ => Form -> Either String a
102+genericFromForm f = to <$> gFromForm f
103+
104+class GFromForm (f :: * -> *) where
105+ gFromForm :: Form -> Either String (f x)
106+
107+instance (GFromForm f, GFromForm g)
108+ => GFromForm (f :*: g) where
109+ gFromForm f = (:*:) <$> gFromForm f <*> gFromForm f
110+
111+instance (GFromForm f, GFromForm g)
112+ => GFromForm (f :+: g) where
113+ gFromForm f = case gFromForm f of
114+ Right a -> return $ L1 a
115+ Left e1 -> case gFromForm f of
116+ Right b -> return $ R1 b
117+ Left e2 -> Left (e1 <> e2)
118+
119+instance (Selector sel, FromHttpApiData f)
120+ => GFromForm (M1 S sel (K1 i f)) where
121+ gFromForm f = case M.lookup sel (unForm f) of
122+ Nothing -> Left . T.unpack $ "Could not find key " <> sel
123+ Just v -> left T.unpack $ M1 . K1 <$> parseUrlPiece v
124+ where sel = T.pack $ selName (Proxy3 :: Proxy3 sel g p)
125+
126+instance (GFromForm f) => GFromForm (M1 D x f) where
127+ gFromForm f = M1 <$> gFromForm f
128+
129+instance (GFromForm f) => GFromForm (M1 C x f) where
130+ gFromForm f = M1 <$> gFromForm f
131+
132+encodeForm :: Form -> BSL.ByteString
133+encodeForm xs =
134+ let escape :: T.Text -> BSL.ByteString
135+ escape = cs . escapeURIString isUnreserved . cs
136+ encodePair :: (T.Text, T.Text) -> BSL.ByteString
137+ encodePair (k, "") = escape k
138+ encodePair (k, v) = escape k <> "=" <> escape v
139+ in BSL.intercalate "&" $ map encodePair $ toList xs
140+
141+decodeForm :: BSL.ByteString -> Either String Form
142+decodeForm "" = return mempty
143+decodeForm q = do
144+ let xs :: [T.Text]
145+ xs = T.splitOn "&" . cs $ q
146+ parsePair :: T.Text -> Either String (T.Text, T.Text)
147+ parsePair p =
148+ case T.splitOn "=" p of
149+ [k,v] -> return ( unescape k
150+ , unescape v
151+ )
152+ [k] -> return ( unescape k, "" )
153+ _ -> Left $ "not a valid pair: " <> cs p
154+ unescape :: T.Text -> T.Text
155+ unescape = cs . unEscapeString . cs . T.intercalate "%20" . T.splitOn "+"
156+ toForm <$> mapM parsePair xs
157+
158+data Proxy3 a b c = Proxy3