module Servant.Server.Internal where
import Control.Applicative ((<$>))
import Control.Monad.Trans.Either (EitherT, runEitherT)
import Data.Aeson (ToJSON, FromJSON, encode, eitherDecode')
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)
import Data.Monoid (Monoid, mempty, mappend)
import Data.Proxy (Proxy(Proxy))
import Data.String (fromString)
import Data.String.Conversions (cs, (<>))
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.HTTP.Types hiding (Header)
import Network.Wai (Response, Request, ResponseReceived, Application, pathInfo, requestBody,
strictRequestBody, lazyRequestBody, requestHeaders, requestMethod,
rawQueryString, responseLBS)
import Servant.API (QueryParams, QueryParam, QueryFlag, MatrixParams, MatrixParam, MatrixFlag, ReqBody, Header, Capture, Get, Delete, Put, Post, Raw, (:>), (:<|>)(..))
import Servant.Common.Text (FromText, fromText)
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 JSON in request body: " ++ err
routingRespond (Right response) =
respond response
data RouteMismatch =
NotFound
| WrongMethod
| InvalidBody String
deriving (Eq, Show)
instance Monoid RouteMismatch where
mempty = NotFound
NotFound `mappend` x = x
WrongMethod `mappend` InvalidBody s = InvalidBody s
WrongMethod `mappend` _ = WrongMethod
InvalidBody s `mappend` _ = InvalidBody s
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 Server layout :: *
route :: Proxy layout -> Server layout -> RoutingApplication
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
type Server (a :<|> b) = Server a :<|> Server b
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 Server (Capture capture a :> sublayout) =
a -> Server sublayout
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 HasServer Delete where
type Server Delete = EitherT (Int, String) IO ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action
respond $ succeedWith $ case e of
Right () ->
responseLBS status204 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance ToJSON result => HasServer (Get result) where
type Server (Get result) = EitherT (Int, String) IO result
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond . succeedWith $ case e of
Right output ->
responseLBS ok200 [("Content-Type", "application/json")] (encode output)
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| 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 Server (Header sym a :> sublayout) =
Maybe a -> Server sublayout
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 ToJSON a => HasServer (Post a) where
type Server (Post a) = EitherT (Int, String) IO a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond . succeedWith $ case e of
Right out ->
responseLBS status201 [("Content-Type", "application/json")] (encode out)
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance ToJSON a => HasServer (Put a) where
type Server (Put a) = EitherT (Int, String) IO a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond . succeedWith $ case e of
Right out ->
responseLBS ok200 [("Content-Type", "application/json")] (encode out)
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParam sym a :> sublayout) where
type Server (QueryParam sym a :> sublayout) =
Maybe a -> Server sublayout
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 Server (QueryParams sym a :> sublayout) =
[a] -> Server sublayout
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 Server (QueryFlag sym :> sublayout) =
Bool -> Server sublayout
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 Server (MatrixParam sym a :> sublayout) =
Maybe a -> Server sublayout
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 Server (MatrixParams sym a :> sublayout) =
[a] -> Server sublayout
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 Server (MatrixFlag sym :> sublayout) =
Bool -> Server sublayout
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 Server Raw = Application
route Proxy rawApplication request respond =
rawApplication request (respond . succeedWith)
instance (FromJSON a, HasServer sublayout)
=> HasServer (ReqBody a :> sublayout) where
type Server (ReqBody a :> sublayout) =
a -> Server sublayout
route Proxy subserver request respond = do
mrqbody <- eitherDecode' <$> lazyRequestBody request
case mrqbody of
Left e -> respond . failWith $ InvalidBody e
Right v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
type Server (path :> sublayout) = Server sublayout
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