{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#endif
module Servant.Server.Internal
( module Servant.Server.Internal
, module Servant.Server.Internal.PathInfo
, module Servant.Server.Internal.Router
, module Servant.Server.Internal.RoutingApplication
, module Servant.Server.Internal.ServantErr
) where
import Control.Applicative ((<$>))
import Control.Monad.Trans.Class (lift)
import Data.Bool (bool)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as BL
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Proxy
import Data.String (fromString)
import Data.String.Conversions (cs, (<>))
import Data.Text (Text)
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
symbolVal)
import Network.HTTP.Types (HeaderName, Method,
Status(..), parseQueryText,
methodGet, methodHead,
hContentType, hAccept)
import Web.HttpApiData (FromHttpApiData,
parseHeaderMaybe,
parseQueryParamMaybe,
parseUrlPieceMaybe,
parseUrlPieces)
import Snap.Core hiding (Headers, Method,
getResponse, headers, route,
method, withRequest)
import Servant.API ((:<|>) (..), (:>), Capture,
CaptureAll, Header,
IsSecure(..), QueryFlag,
QueryParam, QueryParams, Raw,
RemoteHost, ReqBody,
ReflectMethod(..), Verb)
import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..),
AllCTUnrender (..), AllMime(..), canHandleAcceptH)
import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
getHeaders)
import Servant.Server.Internal.PathInfo
import Servant.Server.Internal.Router
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr
import Servant.Server.Internal.SnapShims
class HasServer api where
type ServerT api (m :: * -> *) :: *
route :: MonadSnap m
=> Proxy api
-> Delayed m env (Server api m)
-> Router m env
type Server api m = ServerT api m
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
route Proxy server = choice (route pa ((\ (a :<|> _) -> a) <$> server))
(route pb ((\ (_ :<|> b) -> b) <$> server))
where pa = Proxy :: Proxy a
pb = Proxy :: Proxy b
captured :: FromHttpApiData a => proxy (Capture sym a) -> Text -> Maybe a
captured _ = parseUrlPieceMaybe
instance (FromHttpApiData a, HasServer sublayout)
=> HasServer (Capture capture a :> sublayout) where
type ServerT (Capture capture a :> sublayout) m =
a -> ServerT sublayout m
route Proxy d =
CaptureRouter $
route (Proxy :: Proxy sublayout)
(addCapture d $ \ txt -> case parseUrlPieceMaybe txt of
Nothing -> delayedFail err400
Just v -> return v
)
instance (FromHttpApiData a, HasServer sublayout)
=> HasServer (CaptureAll capture a :> sublayout) where
type ServerT (CaptureAll capture a :> sublayout) m =
[a] -> ServerT sublayout m
route Proxy d =
CaptureAllRouter $
route (Proxy :: Proxy sublayout)
(addCapture d $ \ txts -> case parseUrlPieces txts of
Left _ -> delayedFail err400
Right v -> return v
)
allowedMethodHead :: Method -> Request -> Bool
allowedMethodHead method request =
method == methodGet && unSnapMethod (rqMethod request) == methodHead
allowedMethod :: Method -> Request -> Bool
allowedMethod method request =
allowedMethodHead method request || unSnapMethod (rqMethod request) == method
processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method
-> Maybe [(HeaderName, B.ByteString)]
-> Request -> RouteResult Response
processMethodRouter handleA status method headers request = case handleA of
Nothing -> FailFatal err406
Just (contentT, body) -> Route $ responseLBS status hdrs bdy
where
bdy = if allowedMethodHead method request then "" else body
hdrs = (hContentType, cs contentT) : fromMaybe [] headers
methodCheck :: MonadSnap m => Method -> Request -> DelayedM m ()
methodCheck method request
| allowedMethod method request = return ()
| otherwise = delayedFail err405
acceptCheck :: (AllMime list, MonadSnap m) => Proxy list -> B.ByteString -> DelayedM m ()
acceptCheck proxy accH
| canHandleAcceptH proxy (AcceptHeader accH) = return ()
| otherwise = delayedFail err406
methodRouter :: (AllCTRender ctypes a, MonadSnap m)
=> Method -> Proxy ctypes -> Status
-> Delayed m env (m a)
-> Router m env
methodRouter method proxy status action = leafRouter route'
where
route' env request respond =
let accH = fromMaybe ct_wildcard $ getHeader hAccept request
in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck proxy accH
) env request respond $ \ output -> do
let handleA = handleAcceptH proxy (AcceptHeader accH) output
processMethodRouter handleA status method Nothing request
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v, MonadSnap m)
=> Method -> Proxy ctypes -> Status
-> Delayed m env (m (Headers h v))
-> Router m env
methodRouterHeaders method proxy status action = leafRouter route'
where
route' env request respond =
let accH = fromMaybe ct_wildcard $ getHeader hAccept request
in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck proxy accH
) env request respond $ \ output -> do
let headers = getHeaders output
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
processMethodRouter handleA status method (Just headers) request
instance {-# OVERLAPPABLE #-} (AllCTRender ctypes a,
ReflectMethod method,
KnownNat status)
=> HasServer (Verb method status ctypes a) where
type ServerT (Verb method status ctypes a) m = m a
route Proxy = methodRouter method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
instance {-# OVERLAPPABLE #-} (AllCTRender ctypes a,
ReflectMethod method,
KnownNat status,
GetHeaders (Headers h a))
=> HasServer (Verb method status ctypes (Headers h a)) where
type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
=> HasServer (Header sym a :> sublayout) where
type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
route Proxy subserver =
let mheader req = parseHeaderMaybe =<< getHeader str req
in route (Proxy :: Proxy sublayout) (passToServer subserver mheader)
where str = fromString $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
=> HasServer (QueryParam sym a :> sublayout) where
type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
route Proxy subserver =
let querytext r = parseQueryText $ rqQueryString r
param r =
case lookup paramname (querytext r) of
Nothing -> Nothing
Just Nothing -> Nothing
Just (Just v) -> parseQueryParamMaybe v
in route (Proxy :: Proxy sublayout) (passToServer subserver param)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
=> HasServer (QueryParams sym a :> sublayout) where
type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m
route Proxy subserver =
let querytext r = parseQueryText $ rqQueryString r
parameters r = filter looksLikeParam (querytext r)
values r = mapMaybe (convert . snd) (parameters r)
in route (Proxy :: Proxy sublayout) (passToServer subserver values)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
convert Nothing = Nothing
convert (Just v) = parseQueryParamMaybe v
instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (QueryFlag sym :> sublayout) where
type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m
route Proxy subserver =
let querytext r = parseQueryText $ rqQueryString r
param r = case lookup paramname (querytext r) of
Just Nothing -> True
Just (Just v) -> examine v
Nothing -> False
in route (Proxy :: Proxy sublayout) (passToServer subserver param)
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 = m ()
route Proxy rawApplication = RawRouter $ \ env request respond -> do
r <- runDelayed rawApplication env request
case r of
Route app -> (snapToApplication' app) request (respond . Route)
Fail a -> respond $ Fail a
FailFatal e -> respond $ FailFatal e
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 =
route (Proxy :: Proxy sublayout) (addBodyCheck (subserver ) bodyCheck')
where
bodyCheck' = do
req <- lift getRequest
let contentTypeH = fromMaybe "application/octet-stream" $ getHeader hContentType req
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) <$>
lift (readRequestBody 2147483647)
case mrqbody of
Nothing -> delayedFailFatal err415
Just (Left e) -> delayedFailFatal err400 { errBody = cs e }
Just (Right v) -> return v
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
type ServerT (path :> sublayout) m = ServerT sublayout m
route Proxy subserver =
pathRouter
(cs (symbolVal proxyPath))
(route (Proxy :: Proxy sublayout) subserver)
where proxyPath = Proxy :: Proxy path
instance HasServer api => HasServer (HttpVersion :> api) where
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
route Proxy subserver =
route (Proxy :: Proxy api) (passToServer subserver rqVersion)
instance HasServer api => HasServer (IsSecure :> api) where
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
route Proxy subserver =
route (Proxy :: Proxy api) (passToServer subserver (bool NotSecure Secure . rqIsSecure))
instance HasServer api => HasServer (RemoteHost :> api) where
type ServerT (RemoteHost :> api) m = B.ByteString -> ServerT api m
route Proxy subserver =
route (Proxy :: Proxy api) (passToServer subserver rqHostName)
ct_wildcard :: B.ByteString
ct_wildcard = "*" <> "/" <> "*"