@@ -0,0 +1,866 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE OverlappingInstances #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE TypeOperators #-}
10+module Servant.Server.Internal where
11+
12+import Control.Applicative ((<$>))
13+import Control.Monad.Trans.Either (EitherT, runEitherT)
14+import qualified Data.ByteString as B
15+import qualified Data.ByteString.Lazy as BL
16+import Data.IORef (newIORef, readIORef, writeIORef)
17+import Data.List (unfoldr)
18+import Data.Maybe (catMaybes, fromMaybe)
19+import Data.Monoid (Monoid, mappend, mempty)
20+import Data.String (fromString)
21+import Data.String.Conversions (cs, (<>))
22+import Data.Text (Text)
23+import qualified Data.Text as T
24+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
25+import Data.Typeable
26+import GHC.TypeLits (KnownSymbol, symbolVal)
27+import Network.HTTP.Types hiding (Header, ResponseHeaders)
28+import Network.Wai (Application, Request, Response,
29+ ResponseReceived, lazyRequestBody,
30+ pathInfo, rawQueryString,
31+ requestBody, requestHeaders,
32+ requestMethod, responseLBS,
33+ strictRequestBody)
34+import Servant.API ((:<|>) (..), (:>), Capture,
35+ Canonicalize, Delete, Get, Header,
36+ MatrixFlag, MatrixParam, MatrixParams,
37+ Patch, Post, Put, QueryFlag,
38+ QueryParam, QueryParams, Raw,
39+ ReqBody)
40+import Servant.API.ContentTypes (AcceptHeader (..),
41+ AllCTRender (..),
42+ AllCTUnrender (..))
43+import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)
44+import Servant.Common.Text (FromText, fromText)
45+
46+data ReqBodyState = Uncalled
47+ | Called !B.ByteString
48+ | Done !B.ByteString
49+
50+
51+toApplication :: RoutingApplication -> Application
52+toApplication ra request respond = do
53+ reqBodyRef <- newIORef Uncalled
54+ -- We may need to consume the requestBody more than once. In order to
55+ -- maintain the illusion that 'requestBody' works as expected,
56+ -- 'ReqBodyState' is introduced, and the complete body is memoized and
57+ -- returned as many times as requested with empty "Done" marker chunks in
58+ -- between.
59+ -- See https://github.com/haskell-servant/servant/issues/3
60+ let memoReqBody = do
61+ ior <- readIORef reqBodyRef
62+ case ior of
63+ Uncalled -> do
64+ r <- BL.toStrict <$> strictRequestBody request
65+ writeIORef reqBodyRef $ Done r
66+ return r
67+ Called bs -> do
68+ writeIORef reqBodyRef $ Done bs
69+ return bs
70+ Done bs -> do
71+ writeIORef reqBodyRef $ Called bs
72+ return B.empty
73+
74+ ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
75+ where
76+ routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
77+ routingRespond (Left NotFound) =
78+ respond $ responseLBS notFound404 [] "not found"
79+ routingRespond (Left WrongMethod) =
80+ respond $ responseLBS methodNotAllowed405 [] "method not allowed"
81+ routingRespond (Left (InvalidBody err)) =
82+ respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
83+ routingRespond (Left UnsupportedMediaType) =
84+ respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
85+ routingRespond (Left (HttpError status body)) =
86+ respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
87+ routingRespond (Right response) =
88+ respond response
89+
90+-- Note that the ordering of the constructors has great significance! It
91+-- determines the Ord instance and, consequently, the monoid instance.
92+-- * Route mismatch
93+data RouteMismatch =
94+ NotFound -- ^ the usual "not found" error
95+ | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
96+ | UnsupportedMediaType -- ^ request body has unsupported media type
97+ | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
98+ | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
99+ deriving (Eq, Ord, Show)
100+
101+instance Monoid RouteMismatch where
102+ mempty = NotFound
103+ -- The following isn't great, since it picks @InvalidBody@ based on
104+ -- alphabetical ordering, but any choice would be arbitrary.
105+ --
106+ -- "As one judge said to the other, 'Be just and if you can't be just, be
107+ -- arbitrary'" -- William Burroughs
108+ mappend = max
109+
110+
111+-- | A wrapper around @'Either' 'RouteMismatch' a@.
112+newtype RouteResult a =
113+ RR { routeResult :: Either RouteMismatch a }
114+ deriving (Eq, Show)
115+
116+failWith :: RouteMismatch -> RouteResult a
117+failWith = RR . Left
118+
119+succeedWith :: a -> RouteResult a
120+succeedWith = RR . Right
121+
122+isMismatch :: RouteResult a -> Bool
123+isMismatch (RR (Left _)) = True
124+isMismatch _ = False
125+
126+-- | Like `null . pathInfo`, but works with redundant trailing slashes.
127+pathIsEmpty :: Request -> Bool
128+pathIsEmpty = f . processedPathInfo
129+ where
130+ f [] = True
131+ f [""] = True
132+ f _ = False
133+
134+-- | If we get a `Right`, it has precedence over everything else.
135+--
136+-- This in particular means that if we could get several 'Right's,
137+-- only the first we encounter would be taken into account.
138+instance Monoid (RouteResult a) where
139+ mempty = RR $ Left mempty
140+
141+ RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
142+ RR (Left _) `mappend` RR (Right y) = RR $ Right y
143+ r `mappend` _ = r
144+
145+type RoutingApplication =
146+ Request -- ^ the request, the field 'pathInfo' may be modified by url routing
147+ -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
148+
149+splitMatrixParameters :: Text -> (Text, Text)
150+splitMatrixParameters = T.break (== ';')
151+
152+parsePathInfo :: Request -> [Text]
153+parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo
154+ where mergePairs = concat . unfoldr pairToList
155+ pairToList [] = Nothing
156+ pairToList ((a, b):xs) = Just ([a, b], xs)
157+
158+-- | Returns a processed pathInfo from the request.
159+--
160+-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be
161+-- processed, so routing works as intended. Therefor this function should be used to access
162+-- the pathInfo for routing purposes.
163+processedPathInfo :: Request -> [Text]
164+processedPathInfo r =
165+ case pinfo of
166+ (x:xs) | T.head x == ';' -> xs
167+ _ -> pinfo
168+ where pinfo = parsePathInfo r
169+
170+class HasServer layout where
171+ type ServerT' layout (m :: * -> *) :: *
172+
173+ route :: Proxy layout -> Server' layout -> RoutingApplication
174+
175+type Server layout = Server' (Canonicalize layout)
176+type Server' layout = ServerT' layout (EitherT (Int, String) IO)
177+type ServerT layout m = ServerT' (Canonicalize layout) m
178+
179+-- * Instances
180+
181+-- | A server for @a ':<|>' b@ first tries to match the request against the route
182+-- represented by @a@ and if it fails tries @b@. You must provide a request
183+-- handler for each route.
184+--
185+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
186+-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
187+-- >
188+-- > server :: Server MyApi
189+-- > server = listAllBooks :<|> postBook
190+-- > where listAllBooks = ...
191+-- > postBook book = ...
192+instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
193+
194+ type ServerT' (a :<|> b) m = ServerT' a m :<|> ServerT' b m
195+
196+ route Proxy (a :<|> b) request respond =
197+ route pa a request $ \mResponse ->
198+ if isMismatch mResponse
199+ then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
200+ else respond mResponse
201+
202+ where pa = Proxy :: Proxy a
203+ pb = Proxy :: Proxy b
204+
205+captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
206+captured _ = fromText
207+
208+-- | If you use 'Capture' in one of the endpoints for your API,
209+-- this automatically requires your server-side handler to be a function
210+-- that takes an argument of the type specified by the 'Capture'.
211+-- This lets servant worry about getting it from the URL and turning
212+-- it into a value of the type you specify.
213+--
214+-- You can control how it'll be converted from 'Text' to your type
215+-- by simply providing an instance of 'FromText' for your type.
216+--
217+-- Example:
218+--
219+-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
220+-- >
221+-- > server :: Server MyApi
222+-- > server = getBook
223+-- > where getBook :: Text -> EitherT (Int, String) IO Book
224+-- > getBook isbn = ...
225+instance (KnownSymbol capture, FromText a, HasServer sublayout)
226+ => HasServer (Capture capture a :> sublayout) where
227+
228+ type ServerT' (Capture capture a :> sublayout) m =
229+ a -> ServerT' sublayout m
230+
231+ route Proxy subserver request respond = case processedPathInfo request of
232+ (first : rest)
233+ -> case captured captureProxy first of
234+ Nothing -> respond $ failWith NotFound
235+ Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{
236+ pathInfo = rest
237+ } respond
238+ _ -> respond $ failWith NotFound
239+
240+ where captureProxy = Proxy :: Proxy (Capture capture a)
241+
242+
243+-- | If you have a 'Delete' endpoint in your API,
244+-- the handler for this endpoint is meant to delete
245+-- a resource.
246+--
247+-- The code of the handler will, just like
248+-- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and
249+-- 'Servant.API.Put.Put', run in @EitherT (Int, String) IO ()@.
250+-- The 'Int' represents the status code and the 'String' a message
251+-- to be returned. You can use 'Control.Monad.Trans.Either.left' to
252+-- painlessly error out if the conditions for a successful deletion
253+-- are not met.
254+instance HasServer Delete where
255+
256+ type ServerT' Delete m = m ()
257+
258+ route Proxy action request respond
259+ | pathIsEmpty request && requestMethod request == methodDelete = do
260+ e <- runEitherT action
261+ respond $ succeedWith $ case e of
262+ Right () ->
263+ responseLBS status204 [] ""
264+ Left (status, message) ->
265+ responseLBS (mkStatus status (cs message)) [] (cs message)
266+ | pathIsEmpty request && requestMethod request /= methodDelete =
267+ respond $ failWith WrongMethod
268+ | otherwise = respond $ failWith NotFound
269+
270+-- | When implementing the handler for a 'Get' endpoint,
271+-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
272+-- and 'Servant.API.Put.Put', the handler code runs in the
273+-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
274+-- the status code and the 'String' a message, returned in case of
275+-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
276+-- to quickly fail if some conditions are not met.
277+--
278+-- If successfully returning a value, we use the type-level list, combined
279+-- with the request's @Accept@ header, to encode the value for you
280+-- (returning a status code of 200). If there was no @Accept@ header or it
281+-- was @*/*@, we return encode using the first @Content-Type@ type on the
282+-- list.
283+instance ( AllCTRender ctypes a
284+ ) => HasServer (Get ctypes a) where
285+
286+ type ServerT' (Get ctypes a) m = m a
287+
288+ route Proxy action request respond
289+ | pathIsEmpty request && requestMethod request == methodGet = do
290+ e <- runEitherT action
291+ respond $ case e of
292+ Right output -> do
293+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
294+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
295+ Nothing -> failWith UnsupportedMediaType
296+ Just (contentT, body) -> succeedWith $
297+ responseLBS ok200 [ ("Content-Type" , cs contentT)] body
298+ Left (status, message) -> succeedWith $
299+ responseLBS (mkStatus status (cs message)) [] (cs message)
300+ | pathIsEmpty request && requestMethod request /= methodGet =
301+ respond $ failWith WrongMethod
302+ | otherwise = respond $ failWith NotFound
303+
304+-- '()' ==> 204 No Content
305+instance HasServer (Get ctypes ()) where
306+ type ServerT' (Get ctypes ()) m = m ()
307+ route Proxy action request respond
308+ | pathIsEmpty request && requestMethod request == methodGet = do
309+ e <- runEitherT action
310+ respond . succeedWith $ case e of
311+ Right () -> responseLBS noContent204 [] ""
312+ Left (status, message) ->
313+ responseLBS (mkStatus status (cs message)) [] (cs message)
314+ | pathIsEmpty request && requestMethod request /= methodGet =
315+ respond $ failWith WrongMethod
316+ | otherwise = respond $ failWith NotFound
317+
318+-- Add response headers
319+instance ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where
320+ type ServerT' (Get ctypes (Headers h v)) m = m (Headers h v)
321+ route Proxy action request respond
322+ | pathIsEmpty request && requestMethod request == methodGet = do
323+ e <- runEitherT action
324+ respond $ case e of
325+ Right output -> do
326+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
327+ headers = getHeaders output
328+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
329+ Nothing -> failWith UnsupportedMediaType
330+ Just (contentT, body) -> succeedWith $
331+ responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
332+ Left (status, message) -> succeedWith $
333+ responseLBS (mkStatus status (cs message)) [] (cs message)
334+ | pathIsEmpty request && requestMethod request /= methodGet =
335+ respond $ failWith WrongMethod
336+ | otherwise = respond $ failWith NotFound
337+
338+-- | If you use 'Header' in one of the endpoints for your API,
339+-- this automatically requires your server-side handler to be a function
340+-- that takes an argument of the type specified by 'Header'.
341+-- This lets servant worry about extracting it from the request and turning
342+-- it into a value of the type you specify.
343+--
344+-- All it asks is for a 'FromText' instance.
345+--
346+-- Example:
347+--
348+-- > newtype Referer = Referer Text
349+-- > deriving (Eq, Show, FromText, ToText)
350+-- >
351+-- > -- GET /view-my-referer
352+-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
353+-- >
354+-- > server :: Server MyApi
355+-- > server = viewReferer
356+-- > where viewReferer :: Referer -> EitherT (Int, String) IO referer
357+-- > viewReferer referer = return referer
358+instance (KnownSymbol sym, FromText a, HasServer sublayout)
359+ => HasServer (Header sym a :> sublayout) where
360+
361+ type ServerT' (Header sym a :> sublayout) m =
362+ Maybe a -> ServerT' sublayout m
363+
364+ route Proxy subserver request respond = do
365+ let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
366+ route (Proxy :: Proxy sublayout) (subserver mheader) request respond
367+
368+ where str = fromString $ symbolVal (Proxy :: Proxy sym)
369+
370+-- | When implementing the handler for a 'Post' endpoint,
371+-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
372+-- and 'Servant.API.Put.Put', the handler code runs in the
373+-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
374+-- the status code and the 'String' a message, returned in case of
375+-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
376+-- to quickly fail if some conditions are not met.
377+--
378+-- If successfully returning a value, we use the type-level list, combined
379+-- with the request's @Accept@ header, to encode the value for you
380+-- (returning a status code of 201). If there was no @Accept@ header or it
381+-- was @*/*@, we return encode using the first @Content-Type@ type on the
382+-- list.
383+instance ( AllCTRender ctypes a
384+ ) => HasServer (Post ctypes a) where
385+
386+ type ServerT' (Post ctypes a) m = m a
387+
388+ route Proxy action request respond
389+ | pathIsEmpty request && requestMethod request == methodPost = do
390+ e <- runEitherT action
391+ respond $ case e of
392+ Right output -> do
393+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
394+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
395+ Nothing -> failWith UnsupportedMediaType
396+ Just (contentT, body) -> succeedWith $
397+ responseLBS status201 [ ("Content-Type" , cs contentT)] body
398+ Left (status, message) -> succeedWith $
399+ responseLBS (mkStatus status (cs message)) [] (cs message)
400+ | pathIsEmpty request && requestMethod request /= methodPost =
401+ respond $ failWith WrongMethod
402+ | otherwise = respond $ failWith NotFound
403+
404+instance HasServer (Post ctypes ()) where
405+ type ServerT' (Post ctypes ()) m = m ()
406+ route Proxy action request respond
407+ | pathIsEmpty request && requestMethod request == methodPost = do
408+ e <- runEitherT action
409+ respond . succeedWith $ case e of
410+ Right () -> responseLBS noContent204 [] ""
411+ Left (status, message) ->
412+ responseLBS (mkStatus status (cs message)) [] (cs message)
413+ | pathIsEmpty request && requestMethod request /= methodPost =
414+ respond $ failWith WrongMethod
415+ | otherwise = respond $ failWith NotFound
416+
417+-- Add response headers
418+instance ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where
419+ type ServerT' (Post ctypes (Headers h v)) m = m (Headers h v)
420+ route Proxy action request respond
421+ | pathIsEmpty request && requestMethod request == methodPost = do
422+ e <- runEitherT action
423+ respond $ case e of
424+ Right output -> do
425+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
426+ headers = getHeaders output
427+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
428+ Nothing -> failWith UnsupportedMediaType
429+ Just (contentT, body) -> succeedWith $
430+ responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
431+ Left (status, message) -> succeedWith $
432+ responseLBS (mkStatus status (cs message)) [] (cs message)
433+ | pathIsEmpty request && requestMethod request /= methodPost =
434+ respond $ failWith WrongMethod
435+ | otherwise = respond $ failWith NotFound
436+
437+-- | When implementing the handler for a 'Put' endpoint,
438+-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
439+-- and 'Servant.API.Post.Post', the handler code runs in the
440+-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
441+-- the status code and the 'String' a message, returned in case of
442+-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
443+-- to quickly fail if some conditions are not met.
444+--
445+-- If successfully returning a value, we use the type-level list, combined
446+-- with the request's @Accept@ header, to encode the value for you
447+-- (returning a status code of 200). If there was no @Accept@ header or it
448+-- was @*/*@, we return encode using the first @Content-Type@ type on the
449+-- list.
450+instance ( AllCTRender ctypes a
451+ ) => HasServer (Put ctypes a) where
452+
453+ type ServerT' (Put ctypes a) m = m a
454+
455+ route Proxy action request respond
456+ | pathIsEmpty request && requestMethod request == methodPut = do
457+ e <- runEitherT action
458+ respond $ case e of
459+ Right output -> do
460+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
461+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
462+ Nothing -> failWith UnsupportedMediaType
463+ Just (contentT, body) -> succeedWith $
464+ responseLBS status200 [ ("Content-Type" , cs contentT)] body
465+ Left (status, message) -> succeedWith $
466+ responseLBS (mkStatus status (cs message)) [] (cs message)
467+ | pathIsEmpty request && requestMethod request /= methodPut =
468+ respond $ failWith WrongMethod
469+ | otherwise = respond $ failWith NotFound
470+
471+instance HasServer (Put ctypes ()) where
472+ type ServerT' (Put ctypes ()) m = m ()
473+ route Proxy action request respond
474+ | pathIsEmpty request && requestMethod request == methodPut = do
475+ e <- runEitherT action
476+ respond . succeedWith $ case e of
477+ Right () -> responseLBS noContent204 [] ""
478+ Left (status, message) ->
479+ responseLBS (mkStatus status (cs message)) [] (cs message)
480+ | pathIsEmpty request && requestMethod request /= methodPut =
481+ respond $ failWith WrongMethod
482+ | otherwise = respond $ failWith NotFound
483+
484+-- Add response headers
485+instance ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where
486+ type ServerT' (Put ctypes (Headers h v)) m = m (Headers h v)
487+ route Proxy action request respond
488+ | pathIsEmpty request && requestMethod request == methodPut = do
489+ e <- runEitherT action
490+ respond $ case e of
491+ Right output -> do
492+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
493+ headers = getHeaders output
494+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
495+ Nothing -> failWith UnsupportedMediaType
496+ Just (contentT, body) -> succeedWith $
497+ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
498+ Left (status, message) -> succeedWith $
499+ responseLBS (mkStatus status (cs message)) [] (cs message)
500+ | pathIsEmpty request && requestMethod request /= methodPut =
501+ respond $ failWith WrongMethod
502+ | otherwise = respond $ failWith NotFound
503+
504+-- | When implementing the handler for a 'Patch' endpoint,
505+-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
506+-- and 'Servant.API.Put.Put', the handler code runs in the
507+-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
508+-- the status code and the 'String' a message, returned in case of
509+-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
510+-- to quickly fail if some conditions are not met.
511+--
512+-- If successfully returning a value, we just require that its type has
513+-- a 'ToJSON' instance and servant takes care of encoding it for you,
514+-- yielding status code 200 along the way.
515+instance ( AllCTRender ctypes a
516+ ) => HasServer (Patch ctypes a) where
517+ type ServerT' (Patch ctypes a) m = m a
518+
519+ route Proxy action request respond
520+ | pathIsEmpty request && requestMethod request == methodPatch = do
521+ e <- runEitherT action
522+ respond $ case e of
523+ Right output -> do
524+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
525+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
526+ Nothing -> failWith UnsupportedMediaType
527+ Just (contentT, body) -> succeedWith $
528+ responseLBS status200 [ ("Content-Type" , cs contentT)] body
529+ Left (status, message) -> succeedWith $
530+ responseLBS (mkStatus status (cs message)) [] (cs message)
531+ | pathIsEmpty request && requestMethod request /= methodPatch =
532+ respond $ failWith WrongMethod
533+ | otherwise = respond $ failWith NotFound
534+
535+instance HasServer (Patch ctypes ()) where
536+ type ServerT' (Patch ctypes ()) m = m ()
537+ route Proxy action request respond
538+ | pathIsEmpty request && requestMethod request == methodPatch = do
539+ e <- runEitherT action
540+ respond . succeedWith $ case e of
541+ Right () -> responseLBS noContent204 [] ""
542+ Left (status, message) ->
543+ responseLBS (mkStatus status (cs message)) [] (cs message)
544+ | pathIsEmpty request && requestMethod request /= methodPatch =
545+ respond $ failWith WrongMethod
546+ | otherwise = respond $ failWith NotFound
547+
548+-- Add response headers
549+instance ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where
550+ type ServerT' (Patch ctypes (Headers h v)) m = m (Headers h v)
551+ route Proxy action request respond
552+ | pathIsEmpty request && requestMethod request == methodPatch = do
553+ e <- runEitherT action
554+ respond $ case e of
555+ Right outpatch -> do
556+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
557+ headers = getHeaders outpatch
558+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of
559+ Nothing -> failWith UnsupportedMediaType
560+ Just (contentT, body) -> succeedWith $
561+ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
562+ Left (status, message) -> succeedWith $
563+ responseLBS (mkStatus status (cs message)) [] (cs message)
564+ | pathIsEmpty request && requestMethod request /= methodPatch =
565+ respond $ failWith WrongMethod
566+ | otherwise = respond $ failWith NotFound
567+
568+-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
569+-- this automatically requires your server-side handler to be a function
570+-- that takes an argument of type @'Maybe' 'Text'@.
571+--
572+-- This lets servant worry about looking it up in the query string
573+-- and turning it into a value of the type you specify, enclosed
574+-- in 'Maybe', because it may not be there and servant would then
575+-- hand you 'Nothing'.
576+--
577+-- You can control how it'll be converted from 'Text' to your type
578+-- by simply providing an instance of 'FromText' for your type.
579+--
580+-- Example:
581+--
582+-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
583+-- >
584+-- > server :: Server MyApi
585+-- > server = getBooksBy
586+-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]
587+-- > getBooksBy Nothing = ...return all books...
588+-- > getBooksBy (Just author) = ...return books by the given author...
589+instance (KnownSymbol sym, FromText a, HasServer sublayout)
590+ => HasServer (QueryParam sym a :> sublayout) where
591+
592+ type ServerT' (QueryParam sym a :> sublayout) m =
593+ Maybe a -> ServerT' sublayout m
594+
595+ route Proxy subserver request respond = do
596+ let querytext = parseQueryText $ rawQueryString request
597+ param =
598+ case lookup paramname querytext of
599+ Nothing -> Nothing -- param absent from the query string
600+ Just Nothing -> Nothing -- param present with no value -> Nothing
601+ Just (Just v) -> fromText v -- if present, we try to convert to
602+ -- the right type
603+
604+ route (Proxy :: Proxy sublayout) (subserver param) request respond
605+
606+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)
607+
608+-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
609+-- this automatically requires your server-side handler to be a function
610+-- that takes an argument of type @['Text']@.
611+--
612+-- This lets servant worry about looking up 0 or more values in the query string
613+-- associated to @authors@ and turning each of them into a value of
614+-- the type you specify.
615+--
616+-- You can control how the individual values are converted from 'Text' to your type
617+-- by simply providing an instance of 'FromText' for your type.
618+--
619+-- Example:
620+--
621+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
622+-- >
623+-- > server :: Server MyApi
624+-- > server = getBooksBy
625+-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]
626+-- > getBooksBy authors = ...return all books by these authors...
627+instance (KnownSymbol sym, FromText a, HasServer sublayout)
628+ => HasServer (QueryParams sym a :> sublayout) where
629+
630+ type ServerT' (QueryParams sym a :> sublayout) m =
631+ [a] -> ServerT' sublayout m
632+
633+ route Proxy subserver request respond = do
634+ let querytext = parseQueryText $ rawQueryString request
635+ -- if sym is "foo", we look for query string parameters
636+ -- named "foo" or "foo[]" and call fromText on the
637+ -- corresponding values
638+ parameters = filter looksLikeParam querytext
639+ values = catMaybes $ map (convert . snd) parameters
640+
641+ route (Proxy :: Proxy sublayout) (subserver values) request respond
642+
643+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)
644+ looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
645+ convert Nothing = Nothing
646+ convert (Just v) = fromText v
647+
648+-- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API,
649+-- this automatically requires your server-side handler to be a function
650+-- that takes an argument of type 'Bool'.
651+--
652+-- Example:
653+--
654+-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
655+-- >
656+-- > server :: Server MyApi
657+-- > server = getBooks
658+-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book]
659+-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
660+instance (KnownSymbol sym, HasServer sublayout)
661+ => HasServer (QueryFlag sym :> sublayout) where
662+
663+ type ServerT' (QueryFlag sym :> sublayout) m =
664+ Bool -> ServerT' sublayout m
665+
666+ route Proxy subserver request respond = do
667+ let querytext = parseQueryText $ rawQueryString request
668+ param = case lookup paramname querytext of
669+ Just Nothing -> True -- param is there, with no value
670+ Just (Just v) -> examine v -- param with a value
671+ Nothing -> False -- param not in the query string
672+
673+ route (Proxy :: Proxy sublayout) (subserver param) request respond
674+
675+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)
676+ examine v | v == "true" || v == "1" || v == "" = True
677+ | otherwise = False
678+
679+parseMatrixText :: B.ByteString -> QueryText
680+parseMatrixText = parseQueryText
681+
682+-- | If you use @'MatrixParam' "author" Text@ in one of the endpoints for your API,
683+-- this automatically requires your server-side handler to be a function
684+-- that takes an argument of type @'Maybe' 'Text'@.
685+--
686+-- This lets servant worry about looking it up in the query string
687+-- and turning it into a value of the type you specify, enclosed
688+-- in 'Maybe', because it may not be there and servant would then
689+-- hand you 'Nothing'.
690+--
691+-- You can control how it'll be converted from 'Text' to your type
692+-- by simply providing an instance of 'FromText' for your type.
693+--
694+-- Example:
695+--
696+-- > type MyApi = "books" :> MatrixParam "author" Text :> Get [Book]
697+-- >
698+-- > server :: Server MyApi
699+-- > server = getBooksBy
700+-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]
701+-- > getBooksBy Nothing = ...return all books...
702+-- > getBooksBy (Just author) = ...return books by the given author...
703+instance (KnownSymbol sym, FromText a, HasServer sublayout)
704+ => HasServer (MatrixParam sym a :> sublayout) where
705+
706+ type ServerT' (MatrixParam sym a :> sublayout) m =
707+ Maybe a -> ServerT' sublayout m
708+
709+ route Proxy subserver request respond = case parsePathInfo request of
710+ (first : _)
711+ -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first
712+ param = case lookup paramname querytext of
713+ Nothing -> Nothing -- param absent from the query string
714+ Just Nothing -> Nothing -- param present with no value -> Nothing
715+ Just (Just v) -> fromText v -- if present, we try to convert to
716+ -- the right type
717+ route (Proxy :: Proxy sublayout) (subserver param) request respond
718+ _ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond
719+
720+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)
721+
722+-- | If you use @'MatrixParams' "authors" Text@ in one of the endpoints for your API,
723+-- this automatically requires your server-side handler to be a function
724+-- that takes an argument of type @['Text']@.
725+--
726+-- This lets servant worry about looking up 0 or more values in the query string
727+-- associated to @authors@ and turning each of them into a value of
728+-- the type you specify.
729+--
730+-- You can control how the individual values are converted from 'Text' to your type
731+-- by simply providing an instance of 'FromText' for your type.
732+--
733+-- Example:
734+--
735+-- > type MyApi = "books" :> MatrixParams "authors" Text :> Get [Book]
736+-- >
737+-- > server :: Server MyApi
738+-- > server = getBooksBy
739+-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]
740+-- > getBooksBy authors = ...return all books by these authors...
741+instance (KnownSymbol sym, FromText a, HasServer sublayout)
742+ => HasServer (MatrixParams sym a :> sublayout) where
743+
744+ type ServerT' (MatrixParams sym a :> sublayout) m =
745+ [a] -> ServerT' sublayout m
746+
747+ route Proxy subserver request respond = case parsePathInfo request of
748+ (first : _)
749+ -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
750+ -- if sym is "foo", we look for matrix parameters
751+ -- named "foo" or "foo[]" and call fromText on the
752+ -- corresponding values
753+ parameters = filter looksLikeParam matrixtext
754+ values = catMaybes $ map (convert . snd) parameters
755+ route (Proxy :: Proxy sublayout) (subserver values) request respond
756+ _ -> route (Proxy :: Proxy sublayout) (subserver []) request respond
757+
758+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)
759+ looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
760+ convert Nothing = Nothing
761+ convert (Just v) = fromText v
762+
763+-- | If you use @'MatrixFlag' "published"@ in one of the endpoints for your API,
764+-- this automatically requires your server-side handler to be a function
765+-- that takes an argument of type 'Bool'.
766+--
767+-- Example:
768+--
769+-- > type MyApi = "books" :> MatrixFlag "published" :> Get [Book]
770+-- >
771+-- > server :: Server MyApi
772+-- > server = getBooks
773+-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book]
774+-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
775+instance (KnownSymbol sym, HasServer sublayout)
776+ => HasServer (MatrixFlag sym :> sublayout) where
777+
778+ type ServerT' (MatrixFlag sym :> sublayout) m =
779+ Bool -> ServerT' sublayout m
780+
781+ route Proxy subserver request respond = case parsePathInfo request of
782+ (first : _)
783+ -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
784+ param = case lookup paramname matrixtext of
785+ Just Nothing -> True -- param is there, with no value
786+ Just (Just v) -> examine v -- param with a value
787+ Nothing -> False -- param not in the query string
788+
789+ route (Proxy :: Proxy sublayout) (subserver param) request respond
790+
791+ _ -> route (Proxy :: Proxy sublayout) (subserver False) request respond
792+
793+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)
794+ examine v | v == "true" || v == "1" || v == "" = True
795+ | otherwise = False
796+
797+-- | Just pass the request to the underlying application and serve its response.
798+--
799+-- Example:
800+--
801+-- > type MyApi = "images" :> Raw
802+-- >
803+-- > server :: Server MyApi
804+-- > server = serveDirectory "/var/www/images"
805+instance HasServer Raw where
806+
807+ type ServerT' Raw m = Application
808+
809+ route Proxy rawApplication request respond =
810+ rawApplication request (respond . succeedWith)
811+
812+-- | If you use 'ReqBody' in one of the endpoints for your API,
813+-- this automatically requires your server-side handler to be a function
814+-- that takes an argument of the type specified by 'ReqBody'.
815+-- The @Content-Type@ header is inspected, and the list provided is used to
816+-- attempt deserialization. If the request does not have a @Content-Type@
817+-- header, it is treated as @application/octet-stream@.
818+-- This lets servant worry about extracting it from the request and turning
819+-- it into a value of the type you specify.
820+--
821+--
822+-- All it asks is for a 'FromJSON' instance.
823+--
824+-- Example:
825+--
826+-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
827+-- >
828+-- > server :: Server MyApi
829+-- > server = postBook
830+-- > where postBook :: Book -> EitherT (Int, String) IO Book
831+-- > postBook book = ...insert into your db...
832+instance ( AllCTUnrender list a, HasServer sublayout
833+ ) => HasServer (ReqBody list a :> sublayout) where
834+
835+ type ServerT' (ReqBody list a :> sublayout) m =
836+ a -> ServerT' sublayout m
837+
838+ route Proxy subserver request respond = do
839+ -- See HTTP RFC 2616, section 7.2.1
840+ -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
841+ -- See also "W3C Internet Media Type registration, consistency of use"
842+ -- http://www.w3.org/2001/tag/2002/0129-mime
843+ let contentTypeH = fromMaybe "application/octet-stream"
844+ $ lookup hContentType $ requestHeaders request
845+ mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
846+ <$> lazyRequestBody request
847+ case mrqbody of
848+ Nothing -> respond . failWith $ UnsupportedMediaType
849+ Just (Left e) -> respond . failWith $ InvalidBody e
850+ Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond
851+
852+-- | Make sure the incoming request starts with @"/path"@, strip it and
853+-- pass the rest of the request path to @sublayout@.
854+instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
855+
856+ type ServerT' (path :> sublayout) m = ServerT' sublayout m
857+
858+ route Proxy subserver request respond = case processedPathInfo request of
859+ (first : rest)
860+ | first == cs (symbolVal proxyPath)
861+ -> route (Proxy :: Proxy sublayout) subserver request{
862+ pathInfo = rest
863+ } respond
864+ _ -> respond $ failWith NotFound
865+
866+ where proxyPath = Proxy :: Proxy path