@@ -1,45 +1,53 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE PolyKinds #-}
3−{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE TypeOperators #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
74{-# LANGUAGE OverlappingInstances #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE TypeOperators #-}
910module Servant.Server.Internal where
1011
11−import Control.Applicative ((<$>))
12−import Control.Monad.Trans.Either (EitherT, runEitherT)
13−import qualified Data.ByteString as B
14−import qualified Data.ByteString.Lazy as BL
15−import Data.IORef (newIORef, readIORef, writeIORef)
16−import Data.List (unfoldr)
17−import Data.Maybe (catMaybes, fromMaybe)
18−import Data.Monoid (Monoid, mempty, mappend)
19−import Data.String (fromString)
20−import Data.String.Conversions (cs, (<>))
21−import Data.Text.Encoding (decodeUtf8, encodeUtf8)
22−import Data.Text (Text)
23−import qualified Data.Text as T
24−import Data.Typeable
25−import GHC.TypeLits (KnownSymbol, symbolVal)
26−import Network.HTTP.Types hiding (Header)
27−import Network.Wai ( Response, Request, ResponseReceived, Application
28− , pathInfo, requestBody, strictRequestBody
29− , lazyRequestBody, requestHeaders, requestMethod,
30− rawQueryString, responseLBS)
31−import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header
32− , MatrixParams, MatrixParam, MatrixFlag
33− , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..))
34−import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..)
35− , AllCTUnrender(..),)
36−import Servant.Common.Text (FromText, fromText)
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+ Delete, Get, Header, MatrixFlag,
36+ MatrixParam, MatrixParams, Patch,
37+ Post, Put, QueryFlag, QueryParam,
38+ QueryParams, Raw, ReqBody)
39+import Servant.API.ContentTypes (AcceptHeader (..),
40+ AllCTRender (..),
41+ AllCTUnrender (..))
42+import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)
43+import Servant.Common.Text (FromText, fromText)
3744
3845
3946data ReqBodyState = Uncalled
4047 | Called !B.ByteString
4148 | Done !B.ByteString
4249
50+
4351toApplication :: RoutingApplication -> Application
4452toApplication ra request respond = do
4553 reqBodyRef <- newIORef Uncalled
@@ -286,6 +294,7 @@ instance ( AllCTRender ctypes a
286294 respond $ failWith WrongMethod
287295 | otherwise = respond $ failWith NotFound
288296
297+-- '()' ==> 204 No Content
289298instance HasServer (Get ctypes ()) where
290299 type ServerT (Get ctypes ()) m = m ()
291300 route Proxy action request respond
@@ -299,6 +308,26 @@ instance HasServer (Get ctypes ()) where
299308 respond $ failWith WrongMethod
300309 | otherwise = respond $ failWith NotFound
301310
311+-- Add response headers
312+instance ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where
313+ type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
314+ route Proxy action request respond
315+ | pathIsEmpty request && requestMethod request == methodGet = do
316+ e <- runEitherT action
317+ respond $ case e of
318+ Right output -> do
319+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
320+ headers = getHeaders output
321+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
322+ Nothing -> failWith UnsupportedMediaType
323+ Just (contentT, body) -> succeedWith $
324+ responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
325+ Left (status, message) -> succeedWith $
326+ responseLBS (mkStatus status (cs message)) [] (cs message)
327+ | pathIsEmpty request && requestMethod request /= methodGet =
328+ respond $ failWith WrongMethod
329+ | otherwise = respond $ failWith NotFound
330+
302331-- | If you use 'Header' in one of the endpoints for your API,
303332-- this automatically requires your server-side handler to be a function
304333-- that takes an argument of the type specified by 'Header'.
@@ -377,6 +406,26 @@ instance HasServer (Post ctypes ()) where
377406 respond $ failWith WrongMethod
378407 | otherwise = respond $ failWith NotFound
379408
409+-- Add response headers
410+instance ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where
411+ type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
412+ route Proxy action request respond
413+ | pathIsEmpty request && requestMethod request == methodPost = do
414+ e <- runEitherT action
415+ respond $ case e of
416+ Right output -> do
417+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
418+ headers = getHeaders output
419+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
420+ Nothing -> failWith UnsupportedMediaType
421+ Just (contentT, body) -> succeedWith $
422+ responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
423+ Left (status, message) -> succeedWith $
424+ responseLBS (mkStatus status (cs message)) [] (cs message)
425+ | pathIsEmpty request && requestMethod request /= methodPost =
426+ respond $ failWith WrongMethod
427+ | otherwise = respond $ failWith NotFound
428+
380429-- | When implementing the handler for a 'Put' endpoint,
381430-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
382431-- and 'Servant.API.Post.Post', the handler code runs in the
@@ -387,7 +436,7 @@ instance HasServer (Post ctypes ()) where
387436--
388437-- If successfully returning a value, we use the type-level list, combined
389438-- with the request's @Accept@ header, to encode the value for you
390−-- (returning a status code of 201). If there was no @Accept@ header or it
439+-- (returning a status code of 200). If there was no @Accept@ header or it
391440-- was @*/*@, we return encode using the first @Content-Type@ type on the
392441-- list.
393442instance ( AllCTRender ctypes a
@@ -423,6 +472,26 @@ instance HasServer (Put ctypes ()) where
423472 respond $ failWith WrongMethod
424473 | otherwise = respond $ failWith NotFound
425474
475+-- Add response headers
476+instance ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where
477+ type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
478+ route Proxy action request respond
479+ | pathIsEmpty request && requestMethod request == methodPut = do
480+ e <- runEitherT action
481+ respond $ case e of
482+ Right output -> do
483+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
484+ headers = getHeaders output
485+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
486+ Nothing -> failWith UnsupportedMediaType
487+ Just (contentT, body) -> succeedWith $
488+ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
489+ Left (status, message) -> succeedWith $
490+ responseLBS (mkStatus status (cs message)) [] (cs message)
491+ | pathIsEmpty request && requestMethod request /= methodPut =
492+ respond $ failWith WrongMethod
493+ | otherwise = respond $ failWith NotFound
494+
426495-- | When implementing the handler for a 'Patch' endpoint,
427496-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
428497-- and 'Servant.API.Put.Put', the handler code runs in the
@@ -433,7 +502,7 @@ instance HasServer (Put ctypes ()) where
433502--
434503-- If successfully returning a value, we just require that its type has
435504-- a 'ToJSON' instance and servant takes care of encoding it for you,
436−-- yielding status code 201 along the way.
505+-- yielding status code 200 along the way.
437506instance ( AllCTRender ctypes a
438507 ) => HasServer (Patch ctypes a) where
439508 type ServerT (Patch ctypes a) m = m a
@@ -467,6 +536,26 @@ instance HasServer (Patch ctypes ()) where
467536 respond $ failWith WrongMethod
468537 | otherwise = respond $ failWith NotFound
469538
539+-- Add response headers
540+instance ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where
541+ type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
542+ route Proxy action request respond
543+ | pathIsEmpty request && requestMethod request == methodPatch = do
544+ e <- runEitherT action
545+ respond $ case e of
546+ Right outpatch -> do
547+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
548+ headers = getHeaders outpatch
549+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of
550+ Nothing -> failWith UnsupportedMediaType
551+ Just (contentT, body) -> succeedWith $
552+ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
553+ Left (status, message) -> succeedWith $
554+ responseLBS (mkStatus status (cs message)) [] (cs message)
555+ | pathIsEmpty request && requestMethod request /= methodPatch =
556+ respond $ failWith WrongMethod
557+ | otherwise = respond $ failWith NotFound
558+
470559-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
471560-- this automatically requires your server-side handler to be a function
472561-- that takes an argument of type @'Maybe' 'Text'@.