@@ -0,0 +1,459 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE PolyKinds #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE TypeOperators #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+module Servant.Server.Internal where
9+
10+import Control.Applicative
11+import Control.Monad.Trans.Either
12+import Data.Aeson
13+import Data.Maybe (catMaybes)
14+import Data.Monoid
15+import Data.Proxy
16+import Data.String
17+import Data.String.Conversions
18+import Data.Text (Text)
19+import Data.Text.Encoding (decodeUtf8)
20+import GHC.TypeLits
21+import Network.HTTP.Types hiding (Header)
22+import Network.Wai
23+import Servant.API
24+import Servant.Common.Text
25+
26+toApplication :: RoutingApplication -> Application
27+toApplication ra request respond = do
28+ ra request (routingRespond . routeResult)
29+ where
30+ routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
31+ routingRespond (Left NotFound) =
32+ respond $ responseLBS notFound404 [] "not found"
33+ routingRespond (Left WrongMethod) =
34+ respond $ responseLBS methodNotAllowed405 [] "method not allowed"
35+ routingRespond (Left InvalidBody) =
36+ respond $ responseLBS badRequest400 [] "Invalid JSON in request body"
37+ routingRespond (Right response) =
38+ respond response
39+
40+-- * Route mismatch
41+data RouteMismatch =
42+ NotFound -- ^ the usual "not found" error
43+ | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
44+ | InvalidBody -- ^ an even more informative "your json request body wasn't valid" error
45+ deriving (Eq, Show)
46+
47+-- |
48+-- @
49+-- > mempty = NotFound
50+-- >
51+-- > NotFound `mappend` x = x
52+-- > WrongMethod `mappend` InvalidBody = InvalidBody
53+-- > WrongMethod `mappend` _ = WrongMethod
54+-- > InvalidBody `mappend` _ = InvalidBody
55+-- @
56+instance Monoid RouteMismatch where
57+ mempty = NotFound
58+
59+ NotFound `mappend` x = x
60+ WrongMethod `mappend` InvalidBody = InvalidBody
61+ WrongMethod `mappend` _ = WrongMethod
62+ InvalidBody `mappend` _ = InvalidBody
63+
64+-- | A wrapper around @'Either' 'RouteMismatch' a@.
65+newtype RouteResult a =
66+ RR { routeResult :: Either RouteMismatch a }
67+ deriving (Eq, Show)
68+
69+failWith :: RouteMismatch -> RouteResult a
70+failWith = RR . Left
71+
72+succeedWith :: a -> RouteResult a
73+succeedWith = RR . Right
74+
75+isMismatch :: RouteResult a -> Bool
76+isMismatch (RR (Left _)) = True
77+isMismatch _ = False
78+
79+-- | If we get a `Right`, it has precedence over everything else.
80+--
81+-- This in particular means that if we could get several 'Right's,
82+-- only the first we encounter would be taken into account.
83+instance Monoid (RouteResult a) where
84+ mempty = RR $ Left mempty
85+
86+ RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
87+ RR (Left _) `mappend` RR (Right y) = RR $ Right y
88+ r `mappend` _ = r
89+
90+type RoutingApplication =
91+ Request -- ^ the request, the field 'pathInfo' may be modified by url routing
92+ -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
93+
94+class HasServer layout where
95+ type Server layout :: *
96+ route :: Proxy layout -> Server layout -> RoutingApplication
97+
98+-- * Instances
99+
100+-- | A server for @a ':<|>' b@ first tries to match the request again the route
101+-- represented by @a@ and if it fails tries @b@. You must provide a request
102+-- handler for each route.
103+--
104+-- > type MyApi = "books" :> Get [Book] -- GET /books
105+-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
106+-- >
107+-- > server :: Server MyApi
108+-- > server = listAllBooks :<|> postBook
109+-- > where listAllBooks = ...
110+-- > postBook book = ...
111+instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
112+ type Server (a :<|> b) = Server a :<|> Server b
113+ route Proxy (a :<|> b) request respond =
114+ route pa a request $ \ mResponse ->
115+ if isMismatch mResponse
116+ then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
117+ else respond mResponse
118+
119+ where pa = Proxy :: Proxy a
120+ pb = Proxy :: Proxy b
121+
122+captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
123+captured _ = fromText
124+
125+-- | If you use 'Capture' in one of the endpoints for your API,
126+-- this automatically requires your server-side handler to be a function
127+-- that takes an argument of the type specified by the 'Capture'.
128+-- This lets servant worry about getting it from the URL and turning
129+-- it into a value of the type you specify.
130+--
131+-- You can control how it'll be converted from 'Text' to your type
132+-- by simply providing an instance of 'FromText' for your type.
133+--
134+-- Example:
135+--
136+-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book
137+-- >
138+-- > server :: Server MyApi
139+-- > server = getBook
140+-- > where getBook :: Text -> EitherT (Int, String) IO Book
141+-- > getBook isbn = ...
142+instance (KnownSymbol capture, FromText a, HasServer sublayout)
143+ => HasServer (Capture capture a :> sublayout) where
144+
145+ type Server (Capture capture a :> sublayout) =
146+ a -> Server sublayout
147+
148+ route Proxy subserver request respond = case pathInfo request of
149+ (first : rest)
150+ -> case captured captureProxy first of
151+ Nothing -> respond $ failWith NotFound
152+ Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{
153+ pathInfo = rest
154+ } respond
155+ _ -> respond $ failWith NotFound
156+
157+ where captureProxy = Proxy :: Proxy (Capture capture a)
158+
159+-- | If you have a 'Delete' endpoint in your API,
160+-- the handler for this endpoint is meant to delete
161+-- a resource.
162+--
163+-- The code of the handler will, just like
164+-- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and
165+-- 'Servant.API.Put.Put', run in @EitherT (Int, String) IO ()@.
166+-- The 'Int' represents the status code and the 'String' a message
167+-- to be returned. You can use 'Control.Monad.Trans.Either.left' to
168+-- painlessly error out if the conditions for a successful deletion
169+-- are not met.
170+instance HasServer Delete where
171+ type Server Delete = EitherT (Int, String) IO ()
172+
173+ route Proxy action request respond
174+ | null (pathInfo request) && requestMethod request == methodDelete = do
175+ e <- runEitherT action
176+ respond $ succeedWith $ case e of
177+ Right () ->
178+ responseLBS status204 [] ""
179+ Left (status, message) ->
180+ responseLBS (mkStatus status (cs message)) [] (cs message)
181+ | null (pathInfo request) && requestMethod request /= methodDelete =
182+ respond $ failWith WrongMethod
183+ | otherwise = respond $ failWith NotFound
184+
185+-- | When implementing the handler for a 'Get' endpoint,
186+-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
187+-- and 'Servant.API.Put.Put', the handler code runs in the
188+-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
189+-- the status code and the 'String' a message, returned in case of
190+-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
191+-- to quickly fail if some conditions are not met.
192+--
193+-- If successfully returning a value, we just require that its type has
194+-- a 'ToJSON' instance and servant takes care of encoding it for you,
195+-- yielding status code 200 along the way.
196+instance ToJSON result => HasServer (Get result) where
197+ type Server (Get result) = EitherT (Int, String) IO result
198+ route Proxy action request respond
199+ | null (pathInfo request) && requestMethod request == methodGet = do
200+ e <- runEitherT action
201+ respond . succeedWith $ case e of
202+ Right output ->
203+ responseLBS ok200 [("Content-Type", "application/json")] (encode output)
204+ Left (status, message) ->
205+ responseLBS (mkStatus status (cs message)) [] (cs message)
206+ | null (pathInfo request) && requestMethod request /= methodGet =
207+ respond $ failWith WrongMethod
208+ | otherwise = respond $ failWith NotFound
209+
210+-- | If you use 'Header' in one of the endpoints for your API,
211+-- this automatically requires your server-side handler to be a function
212+-- that takes an argument of the type specified by 'Header'.
213+-- This lets servant worry about extracting it from the request and turning
214+-- it into a value of the type you specify.
215+--
216+-- All it asks is for a 'FromText' instance.
217+--
218+-- Example:
219+--
220+-- > newtype Referer = Referer Text
221+-- > deriving (Eq, Show, FromText, ToText)
222+-- >
223+-- > -- GET /view-my-referer
224+-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get Referer
225+-- >
226+-- > server :: Server MyApi
227+-- > server = viewReferer
228+-- > where viewReferer :: Referer -> EitherT (Int, String) IO referer
229+-- > viewReferer referer = return referer
230+instance (KnownSymbol sym, FromText a, HasServer sublayout)
231+ => HasServer (Header sym a :> sublayout) where
232+
233+ type Server (Header sym a :> sublayout) =
234+ Maybe a -> Server sublayout
235+
236+ route Proxy subserver request respond = do
237+ let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
238+ route (Proxy :: Proxy sublayout) (subserver mheader) request respond
239+
240+ where str = fromString $ symbolVal (Proxy :: Proxy sym)
241+
242+-- | When implementing the handler for a 'Post' endpoint,
243+-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
244+-- and 'Servant.API.Put.Put', the handler code runs in the
245+-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
246+-- the status code and the 'String' a message, returned in case of
247+-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
248+-- to quickly fail if some conditions are not met.
249+--
250+-- If successfully returning a value, we just require that its type has
251+-- a 'ToJSON' instance and servant takes care of encoding it for you,
252+-- yielding status code 201 along the way.
253+instance ToJSON a => HasServer (Post a) where
254+ type Server (Post a) = EitherT (Int, String) IO a
255+
256+ route Proxy action request respond
257+ | null (pathInfo request) && requestMethod request == methodPost = do
258+ e <- runEitherT action
259+ respond . succeedWith $ case e of
260+ Right out ->
261+ responseLBS status201 [("Content-Type", "application/json")] (encode out)
262+ Left (status, message) ->
263+ responseLBS (mkStatus status (cs message)) [] (cs message)
264+ | null (pathInfo request) && requestMethod request /= methodPost =
265+ respond $ failWith WrongMethod
266+ | otherwise = respond $ failWith NotFound
267+
268+-- | When implementing the handler for a 'Put' endpoint,
269+-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
270+-- and 'Servant.API.Post.Post', the handler code runs in the
271+-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
272+-- the status code and the 'String' a message, returned in case of
273+-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
274+-- to quickly fail if some conditions are not met.
275+--
276+-- If successfully returning a value, we just require that its type has
277+-- a 'ToJSON' instance and servant takes care of encoding it for you,
278+-- yielding status code 200 along the way.
279+instance ToJSON a => HasServer (Put a) where
280+ type Server (Put a) = EitherT (Int, String) IO a
281+
282+ route Proxy action request respond
283+ | null (pathInfo request) && requestMethod request == methodPut = do
284+ e <- runEitherT action
285+ respond . succeedWith $ case e of
286+ Right out ->
287+ responseLBS ok200 [("Content-Type", "application/json")] (encode out)
288+ Left (status, message) ->
289+ responseLBS (mkStatus status (cs message)) [] (cs message)
290+ | null (pathInfo request) && requestMethod request /= methodPut =
291+ respond $ failWith WrongMethod
292+
293+ | otherwise = respond $ failWith NotFound
294+
295+-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
296+-- this automatically requires your server-side handler to be a function
297+-- that takes an argument of type @'Maybe' 'Text'@.
298+--
299+-- This lets servant worry about looking it up in the query string
300+-- and turning it into a value of the type you specify, enclosed
301+-- in 'Maybe', because it may not be there and servant would then
302+-- hand you 'Nothing'.
303+--
304+-- You can control how it'll be converted from 'Text' to your type
305+-- by simply providing an instance of 'FromText' for your type.
306+--
307+-- Example:
308+--
309+-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book]
310+-- >
311+-- > server :: Server MyApi
312+-- > server = getBooksBy
313+-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]
314+-- > getBooksBy Nothing = ...return all books...
315+-- > getBooksBy (Just author) = ...return books by the given author...
316+instance (KnownSymbol sym, FromText a, HasServer sublayout)
317+ => HasServer (QueryParam sym a :> sublayout) where
318+
319+ type Server (QueryParam sym a :> sublayout) =
320+ Maybe a -> Server sublayout
321+
322+ route Proxy subserver request respond = do
323+ let querytext = parseQueryText $ rawQueryString request
324+ param =
325+ case lookup paramname querytext of
326+ Nothing -> Nothing -- param absent from the query string
327+ Just Nothing -> Nothing -- param present with no value -> Nothing
328+ Just (Just v) -> fromText v -- if present, we try to convert to
329+ -- the right type
330+
331+ route (Proxy :: Proxy sublayout) (subserver param) request respond
332+
333+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)
334+
335+-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
336+-- this automatically requires your server-side handler to be a function
337+-- that takes an argument of type @['Text']@.
338+--
339+-- This lets servant worry about looking up 0 or more values in the query string
340+-- associated to @authors@ and turning each of them into a value of
341+-- the type you specify.
342+--
343+-- You can control how the individual values are converted from 'Text' to your type
344+-- by simply providing an instance of 'FromText' for your type.
345+--
346+-- Example:
347+--
348+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book]
349+-- >
350+-- > server :: Server MyApi
351+-- > server = getBooksBy
352+-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]
353+-- > getBooksBy authors = ...return all books by these authors...
354+instance (KnownSymbol sym, FromText a, HasServer sublayout)
355+ => HasServer (QueryParams sym a :> sublayout) where
356+
357+ type Server (QueryParams sym a :> sublayout) =
358+ [a] -> Server sublayout
359+
360+ route Proxy subserver request respond = do
361+ let querytext = parseQueryText $ rawQueryString request
362+ -- if sym is "foo", we look for query string parameters
363+ -- named "foo" or "foo[]" and call fromText on the
364+ -- corresponding values
365+ parameters = filter looksLikeParam querytext
366+ values = catMaybes $ map (convert . snd) parameters
367+
368+ route (Proxy :: Proxy sublayout) (subserver values) request respond
369+
370+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)
371+ looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
372+ convert Nothing = Nothing
373+ convert (Just v) = fromText v
374+
375+-- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API,
376+-- this automatically requires your server-side handler to be a function
377+-- that takes an argument of type 'Bool'.
378+--
379+-- Example:
380+--
381+-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book]
382+-- >
383+-- > server :: Server MyApi
384+-- > server = getBooks
385+-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book]
386+-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
387+instance (KnownSymbol sym, HasServer sublayout)
388+ => HasServer (QueryFlag sym :> sublayout) where
389+
390+ type Server (QueryFlag sym :> sublayout) =
391+ Bool -> Server sublayout
392+
393+ route Proxy subserver request respond = do
394+ let querytext = parseQueryText $ rawQueryString request
395+ param = case lookup paramname querytext of
396+ Just Nothing -> True -- param is there, with no value
397+ Just (Just v) -> examine v -- param with a value
398+ Nothing -> False -- param not in the query string
399+
400+ route (Proxy :: Proxy sublayout) (subserver param) request respond
401+
402+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)
403+ examine v | v == "true" || v == "1" || v == "" = True
404+ | otherwise = False
405+
406+-- | Just pass the request to the underlying application and serve its response.
407+--
408+-- Example:
409+--
410+-- > type MyApi = "images" :> Raw
411+-- >
412+-- > server :: Server MyApi
413+-- > server = serveDirectory "/var/www/images"
414+instance HasServer Raw where
415+ type Server Raw = Application
416+ route Proxy rawApplication request respond =
417+ rawApplication request (respond . succeedWith)
418+
419+-- | If you use 'ReqBody' in one of the endpoints for your API,
420+-- this automatically requires your server-side handler to be a function
421+-- that takes an argument of the type specified by 'ReqBody'.
422+-- This lets servant worry about extracting it from the request and turning
423+-- it into a value of the type you specify.
424+--
425+-- All it asks is for a 'FromJSON' instance.
426+--
427+-- Example:
428+--
429+-- > type MyApi = "books" :> ReqBody Book :> Post Book
430+-- >
431+-- > server :: Server MyApi
432+-- > server = postBook
433+-- > where postBook :: Book -> EitherT (Int, String) IO Book
434+-- > postBook book = ...insert into your db...
435+instance (FromJSON a, HasServer sublayout)
436+ => HasServer (ReqBody a :> sublayout) where
437+
438+ type Server (ReqBody a :> sublayout) =
439+ a -> Server sublayout
440+
441+ route Proxy subserver request respond = do
442+ mrqbody <- decode' <$> lazyRequestBody request
443+ case mrqbody of
444+ Nothing -> respond $ failWith InvalidBody
445+ Just v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
446+
447+-- | Make sure the incoming request starts with @"/path"@, strip it and
448+-- pass the rest of the request path to @sublayout@.
449+instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
450+ type Server (path :> sublayout) = Server sublayout
451+ route Proxy subserver request respond = case pathInfo request of
452+ (first : rest)
453+ | first == cs (symbolVal proxyPath)
454+ -> route (Proxy :: Proxy sublayout) subserver request{
455+ pathInfo = rest
456+ } respond
457+ _ -> respond $ failWith NotFound
458+
459+ where proxyPath = Proxy :: Proxy path