git.iko.soy/servant
on 2da16c7 help sign in
servant/src/Servant/JQuery/Internal.hs
274 lines 7.8 kB history raw
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE TemplateHaskell #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7module Servant.JQuery.Internal where
9import Control.Applicative
10import Control.Lens
11import Data.Char (toLower)
12import qualified Data.CharSet as Set
13import qualified Data.CharSet.Unicode.Category as Set
14import Data.List
15import Data.Monoid
16import Data.Proxy
17import qualified Data.Text as T
18import GHC.TypeLits
19import Servant.API
21type Arg = String
23data Segment = Static String -- ^ a static path segment. like "/foo"
24 | Cap Arg -- ^ a capture. like "/:userid"
25 deriving (Eq, Show)
28isCapture :: Segment -> Bool
29isCapture (Cap _) = True
30isCapture _ = False
32captureArg :: Segment -> Arg
33captureArg (Cap s) = s
34captureArg _ = error "captureArg called on non capture"
36jsSegments :: [Segment] -> String
37jsSegments [] = "/'"
38jsSegments [x] = "/" ++ segmentToStr x False
39jsSegments (x:xs) = "/" ++ segmentToStr x True ++ jsSegments xs
41segmentToStr :: Segment -> Bool -> String
42segmentToStr (Static s) notTheEnd =
43 if notTheEnd then s else s ++ "'"
44segmentToStr (Cap s) notTheEnd =
45 "' + encodeURIComponent(" ++ s ++ if notTheEnd then ") + '" else ")"
47type Path = [Segment]
49data ArgType =
50 Normal
51 | Flag
52 | List
53 deriving (Eq, Show)
55data QueryArg = QueryArg
56 { _argName :: Arg
57 , _argType :: ArgType
58 } deriving (Eq, Show)
60data HeaderArg = HeaderArg
61 { headerArgName :: String
62 }
63 | ReplaceHeaderArg
64 { headerArgName :: String
65 , headerPattern :: String
66 } deriving (Eq)
68instance Show HeaderArg where
69 show (HeaderArg n) = toValidFunctionName ("header" <> n)
70 show (ReplaceHeaderArg n p)
71 | pn `isPrefixOf` p = pv <> " + \"" <> rp <> "\""
72 | pn `isSuffixOf` p = "\"" <> rp <> "\" + " <> pv
73 | pn `isInfixOf` p = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p)
74 <> "\""
75 | otherwise = p
76 where
77 pv = toValidFunctionName ("header" <> n)
78 pn = "{" <> n <> "}"
79 rp = replace pn "" p
80 -- Use replace method from Data.Text
81 replace old new = T.unpack .
82 T.replace (T.pack old) (T.pack new) .
83 T.pack
85-- | Attempts to reduce the function name provided to that allowed by JS.
86-- https://mathiasbynens.be/notes/javascript-identifiers
87-- Couldn't work out how to handle zero-width characters.
88-- @TODO: specify better default function name, or throw error?
89toValidFunctionName :: String -> String
90toValidFunctionName (x:xs) = [setFirstChar x] <> filter remainder xs
91 where
92 setFirstChar c = if firstChar c
93 then c
94 else '_'
95 firstChar c = (prefixOK c) || (or . map (Set.member c) $ firstLetterOK)
96 remainder c = (prefixOK c) || (or . map (Set.member c) $ remainderOK)
97 -- Valid prefixes
98 prefixOK c = c `elem` ['$','_']
99 -- Unicode character sets
100 firstLetterOK = [ Set.lowercaseLetter
101 , Set.uppercaseLetter
102 , Set.titlecaseLetter
103 , Set.modifierLetter
104 , Set.otherLetter
105 , Set.letterNumber ]
106 remainderOK = firstLetterOK <> [ Set.nonSpacingMark
107 , Set.spacingCombiningMark
108 , Set.decimalNumber
109 , Set.connectorPunctuation ]
110toValidFunctionName [] = "_"
112data Url = Url
113 { _path :: Path
114 , _queryStr :: [QueryArg]
115 } deriving (Eq, Show)
117defUrl :: Url
118defUrl = Url [] []
120type FunctionName = String
121type Method = String
123data AjaxReq = AjaxReq
124 { _reqUrl :: Url
125 , _reqMethod :: Method
126 , _reqHeaders :: [HeaderArg]
127 , _reqBody :: Bool
128 , _funcName :: FunctionName
129 } deriving (Eq, Show)
131makeLenses ''QueryArg
132makeLenses ''Url
133makeLenses ''AjaxReq
135jsParams :: [QueryArg] -> String
136jsParams [] = ""
137jsParams [x] = paramToStr x False
138jsParams (x:xs) = paramToStr x True ++ "&" ++ jsParams xs
140paramToStr :: QueryArg -> Bool -> String
141paramToStr qarg notTheEnd =
142 case qarg ^. argType of
143 Normal -> name
144 ++ "=' + encodeURIComponent("
145 ++ name
146 ++ if notTheEnd then ") + '" else ")"
148 Flag -> name ++ "="
150 List -> name
151 ++ "[]=' + encodeURIComponent("
152 ++ name
153 ++ if notTheEnd then ") + '" else ")"
155 where name = qarg ^. argName
157defReq :: AjaxReq
158defReq = AjaxReq defUrl "GET" [] False ""
160class HasJQ layout where
161 type JQ layout :: *
162 jqueryFor :: Proxy layout -> AjaxReq -> JQ layout
164instance (HasJQ a, HasJQ b)
165 => HasJQ (a :<|> b) where
166 type JQ (a :<|> b) = JQ a :<|> JQ b
168 jqueryFor Proxy req =
169 jqueryFor (Proxy :: Proxy a) req
170 :<|> jqueryFor (Proxy :: Proxy b) req
172instance (KnownSymbol sym, HasJQ sublayout)
173 => HasJQ (Capture sym a :> sublayout) where
174 type JQ (Capture sym a :> sublayout) = JQ sublayout
176 jqueryFor Proxy req =
177 jqueryFor (Proxy :: Proxy sublayout) $
178 req & reqUrl.path <>~ [Cap str]
180 where str = symbolVal (Proxy :: Proxy sym)
182instance HasJQ Delete where
183 type JQ Delete = AjaxReq
185 jqueryFor Proxy req =
186 req & funcName %~ ("delete" <>)
187 & reqMethod .~ "DELETE"
189instance HasJQ (Get a) where
190 type JQ (Get a) = AjaxReq
192 jqueryFor Proxy req =
193 req & funcName %~ ("get" <>)
194 & reqMethod .~ "GET"
196instance (KnownSymbol sym, HasJQ sublayout)
197 => HasJQ (Header sym a :> sublayout) where
198 type JQ (Header sym a :> sublayout) = JQ sublayout
200 jqueryFor Proxy req =
201 jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname])
203 where hname = symbolVal (Proxy :: Proxy sym)
204 subP = Proxy :: Proxy sublayout
206instance HasJQ (Post a) where
207 type JQ (Post a) = AjaxReq
209 jqueryFor Proxy req =
210 req & funcName %~ ("post" <>)
211 & reqMethod .~ "POST"
213instance HasJQ (Put a) where
214 type JQ (Put a) = AjaxReq
216 jqueryFor Proxy req =
217 req & funcName %~ ("put" <>)
218 & reqMethod .~ "PUT"
220instance (KnownSymbol sym, HasJQ sublayout)
221 => HasJQ (QueryParam sym a :> sublayout) where
222 type JQ (QueryParam sym a :> sublayout) = JQ sublayout
224 jqueryFor Proxy req =
225 jqueryFor (Proxy :: Proxy sublayout) $
226 req & reqUrl.queryStr <>~ [QueryArg str Normal]
228 where str = symbolVal (Proxy :: Proxy sym)
229 strArg = str ++ "Value"
231instance (KnownSymbol sym, HasJQ sublayout)
232 => HasJQ (QueryParams sym a :> sublayout) where
233 type JQ (QueryParams sym a :> sublayout) = JQ sublayout
235 jqueryFor Proxy req =
236 jqueryFor (Proxy :: Proxy sublayout) $
237 req & reqUrl.queryStr <>~ [QueryArg str List]
239 where str = symbolVal (Proxy :: Proxy sym)
241instance (KnownSymbol sym, HasJQ sublayout)
242 => HasJQ (QueryFlag sym :> sublayout) where
243 type JQ (QueryFlag sym :> sublayout) = JQ sublayout
245 jqueryFor Proxy req =
246 jqueryFor (Proxy :: Proxy sublayout) $
247 req & reqUrl.queryStr <>~ [QueryArg str Flag]
249 where str = symbolVal (Proxy :: Proxy sym)
251instance HasJQ Raw where
252 type JQ Raw = Method -> AjaxReq
254 jqueryFor Proxy req method =
255 req & funcName %~ ((toLower <$> method) <>)
256 & reqMethod .~ method
258instance HasJQ sublayout => HasJQ (ReqBody a :> sublayout) where
259 type JQ (ReqBody a :> sublayout) = JQ sublayout
261 jqueryFor Proxy req =
262 jqueryFor (Proxy :: Proxy sublayout) $
263 req & reqBody .~ True
265instance (KnownSymbol path, HasJQ sublayout)
266 => HasJQ (path :> sublayout) where
267 type JQ (path :> sublayout) = JQ sublayout
269 jqueryFor Proxy req =
270 jqueryFor (Proxy :: Proxy sublayout) $
271 req & reqUrl.path <>~ [Static str]
272 & funcName %~ (str <>)
274 where str = map (\c -> if c == '.' then '_' else c) $ symbolVal (Proxy :: Proxy path)