#if !MIN_VERSION_base(4,8,0)
#endif
module Servant.Server.Internal where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
import Data.Monoid (Monoid, mappend, mempty)
#endif
import Control.Monad.Trans.Either (EitherT, runEitherT)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.List (unfoldr)
import Data.Maybe (catMaybes, fromMaybe)
import Data.String (fromString)
import Data.String.Conversions (cs, (<>))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Typeable
import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Wai (Application, Request, Response,
ResponseReceived, lazyRequestBody,
pathInfo, rawQueryString,
requestBody, requestHeaders,
requestMethod, responseLBS,
strictRequestBody)
import Servant.API ((:<|>) (..), (:>), Capture,
Delete, Get, Header,
MatrixFlag, MatrixParam, MatrixParams,
Patch, Post, Put, QueryFlag,
QueryParam, QueryParams, Raw,
ReqBody)
import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..),
AllCTUnrender (..))
import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
getHeaders)
import Servant.Common.Text (FromText, fromText)
import Servant.Server.Internal.ServantErr
data ReqBodyState = Uncalled
| Called !B.ByteString
| Done !B.ByteString
toApplication :: RoutingApplication -> Application
toApplication ra request respond = do
reqBodyRef <- newIORef Uncalled
let memoReqBody = do
ior <- readIORef reqBodyRef
case ior of
Uncalled -> do
r <- BL.toStrict <$> strictRequestBody request
writeIORef reqBodyRef $ Done r
return r
Called bs -> do
writeIORef reqBodyRef $ Done bs
return bs
Done bs -> do
writeIORef reqBodyRef $ Called bs
return B.empty
ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
where
routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
routingRespond (Left NotFound) =
respond $ responseLBS notFound404 [] "not found"
routingRespond (Left WrongMethod) =
respond $ responseLBS methodNotAllowed405 [] "method not allowed"
routingRespond (Left (InvalidBody err)) =
respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
routingRespond (Left UnsupportedMediaType) =
respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
routingRespond (Left (HttpError status body)) =
respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
routingRespond (Right response) =
respond response
data RouteMismatch =
NotFound
| WrongMethod
| UnsupportedMediaType
| InvalidBody String
| HttpError Status (Maybe BL.ByteString)
deriving (Eq, Ord, Show)
instance Monoid RouteMismatch where
mempty = NotFound
mappend = max
newtype RouteResult a =
RR { routeResult :: Either RouteMismatch a }
deriving (Eq, Show)
failWith :: RouteMismatch -> RouteResult a
failWith = RR . Left
succeedWith :: a -> RouteResult a
succeedWith = RR . Right
isMismatch :: RouteResult a -> Bool
isMismatch (RR (Left _)) = True
isMismatch _ = False
pathIsEmpty :: Request -> Bool
pathIsEmpty = f . processedPathInfo
where
f [] = True
f [""] = True
f _ = False
instance Monoid (RouteResult a) where
mempty = RR $ Left mempty
RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
RR (Left _) `mappend` RR (Right y) = RR $ Right y
r `mappend` _ = r
type RoutingApplication =
Request
-> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
splitMatrixParameters :: Text -> (Text, Text)
splitMatrixParameters = T.break (== ';')
parsePathInfo :: Request -> [Text]
parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo
where mergePairs = concat . unfoldr pairToList
pairToList [] = Nothing
pairToList ((a, b):xs) = Just ([a, b], xs)
processedPathInfo :: Request -> [Text]
processedPathInfo r =
case pinfo of
(x:xs) | T.head x == ';' -> xs
_ -> pinfo
where pinfo = parsePathInfo r
class HasServer layout where
type ServerT layout (m :: * -> *) :: *
route :: Proxy layout -> Server layout -> RoutingApplication
type Server layout = ServerT layout (EitherT ServantErr IO)
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
route Proxy (a :<|> b) request respond =
route pa a request $ \mResponse ->
if isMismatch mResponse
then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
else respond mResponse
where pa = Proxy :: Proxy a
pb = Proxy :: Proxy b
captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
captured _ = fromText
instance (KnownSymbol capture, FromText a, HasServer sublayout)
=> HasServer (Capture capture a :> sublayout) where
type ServerT (Capture capture a :> sublayout) m =
a -> ServerT sublayout m
route Proxy subserver request respond = case processedPathInfo request of
(first : rest)
-> case captured captureProxy first of
Nothing -> respond $ failWith NotFound
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{
pathInfo = rest
} respond
_ -> respond $ failWith NotFound
where captureProxy = Proxy :: Proxy (Capture capture a)
instance
#if MIN_VERSION_base(4,8,0)
#endif
( AllCTRender ctypes a
) => HasServer (Delete ctypes a) where
type ServerT (Delete ctypes a) m = m a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance
#if MIN_VERSION_base(4,8,0)
#endif
HasServer (Delete ctypes ()) where
type ServerT (Delete ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance
#if MIN_VERSION_base(4,8,0)
#endif
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Delete ctypes (Headers h v)) where
type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance
#if MIN_VERSION_base(4,8,0)
#endif
( AllCTRender ctypes a ) => HasServer (Get ctypes a) where
type ServerT (Get ctypes a) m = m a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS ok200 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance
#if MIN_VERSION_base(4,8,0)
#endif
HasServer (Get ctypes ()) where
type ServerT (Get ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance
#if MIN_VERSION_base(4,8,0)
#endif
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Get ctypes (Headers h v)) where
type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (Header sym a :> sublayout) where
type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
route Proxy subserver request respond = do
let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
route (Proxy :: Proxy sublayout) (subserver mheader) request respond
where str = fromString $ symbolVal (Proxy :: Proxy sym)
instance
#if MIN_VERSION_base(4,8,0)
#endif
( AllCTRender ctypes a
) => HasServer (Post ctypes a) where
type ServerT (Post ctypes a) m = m a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status201 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance
#if MIN_VERSION_base(4,8,0)
#endif
HasServer (Post ctypes ()) where
type ServerT (Post ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance
#if MIN_VERSION_base(4,8,0)
#endif
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Post ctypes (Headers h v)) where
type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance
#if MIN_VERSION_base(4,8,0)
#endif
( AllCTRender ctypes a) => HasServer (Put ctypes a) where
type ServerT (Put ctypes a) m = m a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance
#if MIN_VERSION_base(4,8,0)
#endif
HasServer (Put ctypes ()) where
type ServerT (Put ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance
#if MIN_VERSION_base(4,8,0)
#endif
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Put ctypes (Headers h v)) where
type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance
#if MIN_VERSION_base(4,8,0)
#endif
( AllCTRender ctypes a) => HasServer (Patch ctypes a) where
type ServerT (Patch ctypes a) m = m a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance
#if MIN_VERSION_base(4,8,0)
#endif
HasServer (Patch ctypes ()) where
type ServerT (Patch ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance
#if MIN_VERSION_base(4,8,0)
#endif
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Patch ctypes (Headers h v)) where
type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond $ case e of
Right outpatch -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders outpatch
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParam sym a :> sublayout) where
type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request
param =
case lookup paramname querytext of
Nothing -> Nothing
Just Nothing -> Nothing
Just (Just v) -> fromText v
route (Proxy :: Proxy sublayout) (subserver param) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParams sym a :> sublayout) where
type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m
route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request
parameters = filter looksLikeParam querytext
values = catMaybes $ map (convert . snd) parameters
route (Proxy :: Proxy sublayout) (subserver values) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
convert Nothing = Nothing
convert (Just v) = fromText v
instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (QueryFlag sym :> sublayout) where
type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m
route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request
param = case lookup paramname querytext of
Just Nothing -> True
Just (Just v) -> examine v
Nothing -> False
route (Proxy :: Proxy sublayout) (subserver param) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True
| otherwise = False
parseMatrixText :: B.ByteString -> QueryText
parseMatrixText = parseQueryText
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParam sym a :> sublayout) where
type ServerT (MatrixParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of
(first : _)
-> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first
param = case lookup paramname querytext of
Nothing -> Nothing
Just Nothing -> Nothing
Just (Just v) -> fromText v
route (Proxy :: Proxy sublayout) (subserver param) request respond
_ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParams sym a :> sublayout) where
type ServerT (MatrixParams sym a :> sublayout) m =
[a] -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of
(first : _)
-> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
parameters = filter looksLikeParam matrixtext
values = catMaybes $ map (convert . snd) parameters
route (Proxy :: Proxy sublayout) (subserver values) request respond
_ -> route (Proxy :: Proxy sublayout) (subserver []) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
convert Nothing = Nothing
convert (Just v) = fromText v
instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (MatrixFlag sym :> sublayout) where
type ServerT (MatrixFlag sym :> sublayout) m =
Bool -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of
(first : _)
-> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
param = case lookup paramname matrixtext of
Just Nothing -> True
Just (Just v) -> examine v
Nothing -> False
route (Proxy :: Proxy sublayout) (subserver param) request respond
_ -> route (Proxy :: Proxy sublayout) (subserver False) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True
| otherwise = False
instance HasServer Raw where
type ServerT Raw m = Application
route Proxy rawApplication request respond =
rawApplication request (respond . succeedWith)
instance ( AllCTUnrender list a, HasServer sublayout
) => HasServer (ReqBody list a :> sublayout) where
type ServerT (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m
route Proxy subserver request respond = do
let contentTypeH = fromMaybe "application/octet-stream"
$ lookup hContentType $ requestHeaders request
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
<$> lazyRequestBody request
case mrqbody of
Nothing -> respond . failWith $ UnsupportedMediaType
Just (Left e) -> respond . failWith $ InvalidBody e
Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
type ServerT (path :> sublayout) m = ServerT sublayout m
route Proxy subserver request respond = case processedPathInfo request of
(first : rest)
| first == cs (symbolVal proxyPath)
-> route (Proxy :: Proxy sublayout) subserver request{
pathInfo = rest
} respond
_ -> respond $ failWith NotFound
where proxyPath = Proxy :: Proxy path
ct_wildcard :: B.ByteString
ct_wildcard = "*" <> "/" <> "*"