@@ -1,19 +1,3 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−#if !MIN_VERSION_base(4,8,0)
7−{-# LANGUAGE NullaryTypeClasses #-}
8−#endif
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TemplateHaskell #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−{-# LANGUAGE OverloadedStrings #-}
16−
171-- | Generalizes all the data needed to make code generation work with
182-- arbitrary programming languages.
193module Servant.Foreign
@@ -46,244 +30,5 @@ module Servant.Foreign
4630 , module Servant.API
4731 ) where
4832
49−import Control.Lens (makeLenses, (%~), (&), (.~), (<>~))
50−import qualified Data.Char as C
51−import Data.Proxy
52−import Data.Text
53−import GHC.Exts (Constraint)
54−import GHC.TypeLits
55−import Prelude hiding (concat)
56−import Servant.API
57−
58−-- | Function name builder that simply concat each part together
59−concatCase :: FunctionName -> Text
60−concatCase = concat
61−
62−-- | Function name builder using the snake_case convention.
63−-- each part is separated by a single underscore character.
64−snakeCase :: FunctionName -> Text
65−snakeCase = intercalate "_"
66−
67−-- | Function name builder using the CamelCase convention.
68−-- each part begins with an upper case character.
69−camelCase :: FunctionName -> Text
70−camelCase = camelCase' . Prelude.map (replace "-" "")
71− where camelCase' [] = ""
72− camelCase' (p:ps) = concat $ p : Prelude.map capitalize ps
73− capitalize "" = ""
74− capitalize name = C.toUpper (Data.Text.head name) `cons` Data.Text.tail name
75−
76−type Arg = Text
77−
78−newtype Segment = Segment { _segment :: SegmentType }
79− deriving (Eq, Show)
80−
81−data SegmentType = Static Text -- ^ a static path segment. like "/foo"
82− | Cap Arg -- ^ a capture. like "/:userid"
83− deriving (Eq, Show)
84−
85−type Path = [Segment]
86−
87−data ArgType =
88− Normal
89− | Flag
90− | List
91− deriving (Eq, Show)
92−
93−data QueryArg = QueryArg
94− { _argName :: Arg
95− , _argType :: ArgType
96− } deriving (Eq, Show)
97−
98−data HeaderArg = HeaderArg
99− { headerArgName :: Text
100− }
101− | ReplaceHeaderArg
102− { headerArgName :: Text
103− , headerPattern :: Text
104− } deriving (Eq, Show)
105−
106−
107−data Url = Url
108− { _path :: Path
109− , _queryStr :: [QueryArg]
110− } deriving (Eq, Show)
111−
112−defUrl :: Url
113−defUrl = Url [] []
114−
115−type FunctionName = [Text]
116−type Method = Text
117−
118−data Req = Req
119− { _reqUrl :: Url
120− , _reqMethod :: Method
121− , _reqHeaders :: [HeaderArg]
122− , _reqBody :: Bool
123− , _funcName :: FunctionName
124− } deriving (Eq, Show)
125−
126−makeLenses ''QueryArg
127−makeLenses ''Segment
128−makeLenses ''Url
129−makeLenses ''Req
130−
131−isCapture :: Segment -> Bool
132−isCapture (Segment (Cap _)) = True
133−isCapture _ = False
134−
135−captureArg :: Segment -> Arg
136−captureArg (Segment (Cap s)) = s
137−captureArg _ = error "captureArg called on non capture"
138−
139−defReq :: Req
140−defReq = Req defUrl "GET" [] False []
141−
142−-- | To be used exclusively as a "negative" return type/constraint
143−-- by @'Elem`@ type family.
144−class NotFound
145−
146−type family Elem (a :: *) (ls::[*]) :: Constraint where
147− Elem a '[] = NotFound
148− Elem a (a ': list) = ()
149− Elem a (b ': list) = Elem a list
150−
151−class HasForeign (layout :: *) where
152− type Foreign layout :: *
153− foreignFor :: Proxy layout -> Req -> Foreign layout
154−
155−instance (HasForeign a, HasForeign b)
156− => HasForeign (a :<|> b) where
157− type Foreign (a :<|> b) = Foreign a :<|> Foreign b
158−
159− foreignFor Proxy req =
160− foreignFor (Proxy :: Proxy a) req
161− :<|> foreignFor (Proxy :: Proxy b) req
162−
163−instance (KnownSymbol sym, HasForeign sublayout)
164− => HasForeign (Capture sym a :> sublayout) where
165− type Foreign (Capture sym a :> sublayout) = Foreign sublayout
166−
167− foreignFor Proxy req =
168− foreignFor (Proxy :: Proxy sublayout) $
169− req & reqUrl.path <>~ [Segment (Cap str)]
170− & funcName %~ (++ ["by", str])
171−
172− where str = pack . symbolVal $ (Proxy :: Proxy sym)
173−
174−instance Elem JSON list => HasForeign (Delete list a) where
175− type Foreign (Delete list a) = Req
176−
177− foreignFor Proxy req =
178− req & funcName %~ ("delete" :)
179− & reqMethod .~ "DELETE"
180−
181−instance Elem JSON list => HasForeign (Get list a) where
182− type Foreign (Get list a) = Req
183−
184− foreignFor Proxy req =
185− req & funcName %~ ("get" :)
186− & reqMethod .~ "GET"
187−
188−instance (KnownSymbol sym, HasForeign sublayout)
189− => HasForeign (Header sym a :> sublayout) where
190− type Foreign (Header sym a :> sublayout) = Foreign sublayout
191−
192− foreignFor Proxy req =
193− foreignFor subP (req & reqHeaders <>~ [HeaderArg hname])
194−
195− where hname = pack . symbolVal $ (Proxy :: Proxy sym)
196− subP = Proxy :: Proxy sublayout
197−
198−instance Elem JSON list => HasForeign (Post list a) where
199− type Foreign (Post list a) = Req
200−
201− foreignFor Proxy req =
202− req & funcName %~ ("post" :)
203− & reqMethod .~ "POST"
204−
205−instance Elem JSON list => HasForeign (Put list a) where
206− type Foreign (Put list a) = Req
207−
208− foreignFor Proxy req =
209− req & funcName %~ ("put" :)
210− & reqMethod .~ "PUT"
211−
212−instance (KnownSymbol sym, HasForeign sublayout)
213− => HasForeign (QueryParam sym a :> sublayout) where
214− type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout
215−
216− foreignFor Proxy req =
217− foreignFor (Proxy :: Proxy sublayout) $
218− req & reqUrl.queryStr <>~ [QueryArg str Normal]
219−
220− where str = pack . symbolVal $ (Proxy :: Proxy sym)
221−
222−instance (KnownSymbol sym, HasForeign sublayout)
223− => HasForeign (QueryParams sym a :> sublayout) where
224− type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout
225−
226− foreignFor Proxy req =
227− foreignFor (Proxy :: Proxy sublayout) $
228− req & reqUrl.queryStr <>~ [QueryArg str List]
229−
230− where str = pack . symbolVal $ (Proxy :: Proxy sym)
231−
232−instance (KnownSymbol sym, HasForeign sublayout)
233− => HasForeign (QueryFlag sym :> sublayout) where
234− type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout
235−
236− foreignFor Proxy req =
237− foreignFor (Proxy :: Proxy sublayout) $
238− req & reqUrl.queryStr <>~ [QueryArg str Flag]
239−
240− where str = pack . symbolVal $ (Proxy :: Proxy sym)
241−
242−instance HasForeign Raw where
243− type Foreign Raw = Method -> Req
244−
245− foreignFor Proxy req method =
246− req & funcName %~ ((toLower method) :)
247− & reqMethod .~ method
248−
249−instance (Elem JSON list, HasForeign sublayout) => HasForeign (ReqBody list a :> sublayout) where
250− type Foreign (ReqBody list a :> sublayout) = Foreign sublayout
251−
252− foreignFor Proxy req =
253− foreignFor (Proxy :: Proxy sublayout) $
254− req & reqBody .~ True
255−
256−instance (KnownSymbol path, HasForeign sublayout)
257− => HasForeign (path :> sublayout) where
258− type Foreign (path :> sublayout) = Foreign sublayout
259−
260− foreignFor Proxy req =
261− foreignFor (Proxy :: Proxy sublayout) $
262− req & reqUrl.path <>~ [Segment (Static str)]
263− & funcName %~ (++ [str])
264−
265− where str = Data.Text.map (\c -> if c == '.' then '_' else c) . pack . symbolVal $ (Proxy :: Proxy path)
266−
267−instance HasForeign sublayout => HasForeign (RemoteHost :> sublayout) where
268− type Foreign (RemoteHost :> sublayout) = Foreign sublayout
269−
270− foreignFor Proxy req =
271− foreignFor (Proxy :: Proxy sublayout) req
272−
273−instance HasForeign sublayout => HasForeign (IsSecure :> sublayout) where
274− type Foreign (IsSecure :> sublayout) = Foreign sublayout
275−
276− foreignFor Proxy req =
277− foreignFor (Proxy :: Proxy sublayout) req
278−
279−instance HasForeign sublayout => HasForeign (Vault :> sublayout) where
280− type Foreign (Vault :> sublayout) = Foreign sublayout
281−
282− foreignFor Proxy req =
283− foreignFor (Proxy :: Proxy sublayout) req
284−
285−instance HasForeign sublayout => HasForeign (HttpVersion :> sublayout) where
286− type Foreign (HttpVersion :> sublayout) = Foreign sublayout
287−
288− foreignFor Proxy req =
289− foreignFor (Proxy :: Proxy sublayout) req
33+import Servant.API
34+import Servant.Foreign.Internal