module Webby.Server where
import qualified Data.Aeson as A
import qualified Data.Binary.Builder as Bu
import qualified Data.ByteString.Lazy as LB
import qualified Data.HashMap.Strict as H
import qualified Data.List as L
import qualified Data.Text as T
import Network.HTTP.Types.URI (queryToQueryText)
import Network.Wai.Internal (getRequestBodyChunk)
import qualified UnliftIO.Concurrent as Conc
import qualified UnliftIO.Exception as E
import Web.HttpApiData
import Prelude
import Webby.Types
getAppEnv :: WebbyM appEnv appEnv
getAppEnv = asks weAppEnv
runAppEnv :: ReaderT appEnv (WebbyM appEnv) a -> WebbyM appEnv a
runAppEnv appFn = do
env <- getAppEnv
runReaderT appFn env
captures :: WebbyM appEnv Captures
captures = asks weCaptures
getCapture :: (FromHttpApiData a) => Text -> WebbyM appEnv a
getCapture capName = do
cs <- captures
case H.lookup capName cs of
Nothing -> throwIO $ WebbyMissingCapture capName
Just cap -> either (throwIO . WebbyParamParseError capName . show)
return $
parseUrlPiece cap
setStatus :: Status -> WebbyM appEnv ()
setStatus sts = do
wVar <- asks weResp
Conc.modifyMVar_ wVar $ \wr -> return $ wr { wrStatus = sts}
addHeader :: Header -> WebbyM appEnv ()
addHeader h = do
wVar <- asks weResp
Conc.modifyMVar_ wVar $
\wr -> do let hs = wrHeaders wr
return $ wr { wrHeaders = hs ++ [h] }
setHeader :: Header -> WebbyM appEnv ()
setHeader (k, v) = do
wVar <- asks weResp
Conc.modifyMVar_ wVar $
\wr -> do let hs = wrHeaders wr
ohs = filter ((/= k) . fst) hs
return $ wr { wrHeaders = ohs ++ [(k, v)] }
resp400 :: Text -> WebbyM appEnv a
resp400 msg = do
setStatus status400
json $ A.object [ "error" A..= A.String msg ]
finish
params :: WebbyM appEnv [(Text, Text)]
params = do
qparams <- (queryToQueryText . queryString) <$> request
return $ fmap (\(q, mv) -> (,) q $ fromMaybe "" mv) qparams
flag :: Text -> WebbyM appEnv Bool
flag name = (isJust . L.lookup name) <$> params
param :: (FromHttpApiData a) => Text -> WebbyM appEnv (Maybe a)
param p = do ps <- params
case L.lookup p ps of
Nothing -> return Nothing
Just myParam -> either (throwIO . WebbyParamParseError p . show)
(return . Just) $
parseQueryParam myParam
param_ :: (FromHttpApiData a) => Text -> WebbyM appEnv a
param_ p = do myParam <- param p
maybe (resp400 $ T.concat [p, " missing in params"])
return myParam
header :: HeaderName -> WebbyM appEnv (Maybe Text)
header n = do
hs <- requestHeaders <$> request
return $ headMay $ map (decodeUtf8 . snd) $ filter ((n == ) . fst) hs
request :: WebbyM appEnv Request
request = asks weRequest
getRequestBodyChunkAction :: WebbyM appEnv (WebbyM appEnv ByteString)
getRequestBodyChunkAction = (liftIO . getRequestBodyChunk) <$> asks weRequest
headers :: WebbyM appEnv [Header]
headers = requestHeaders <$> request
requestBodyLength :: WebbyM appEnv (Maybe Int64)
requestBodyLength = do
hMay <- header hContentLength
return $ do val <- hMay
parseInt val
finish :: WebbyM appEnv a
finish = E.throwIO FinishThrown
blob :: ByteString -> WebbyM appEnv ()
blob bs = do
setHeader (hContentType, "application/octet-stream")
wVar <- asks weResp
Conc.modifyMVar_ wVar $
\wr -> return $ wr { wrRespData = Right $ Bu.fromByteString bs }
text :: Text -> WebbyM appEnv ()
text txt = do
setHeader (hContentType, "text/plain; charset=utf-8")
wVar <- asks weResp
Conc.modifyMVar_ wVar $
\wr -> return $ wr { wrRespData = Right $ Bu.fromByteString $
encodeUtf8 txt }
requestBodyLBS :: WebbyM appEnv LByteString
requestBodyLBS = do
req <- request
liftIO $ lazyRequestBody req
jsonData :: A.FromJSON a => WebbyM appEnv a
jsonData = do
req <- request
body <- liftIO $ lazyRequestBody req
either (throwIO . WebbyJSONParseError . T.pack) return $ A.eitherDecode body
json :: A.ToJSON b => b -> WebbyM appEnv ()
json j = do
setHeader (hContentType, "application/json; charset=utf-8")
wVar <- asks weResp
Conc.modifyMVar_ wVar $
\wr -> return $ wr { wrRespData = Right $ Bu.fromLazyByteString $
A.encode j }
stream :: StreamingBody -> WebbyM appEnv ()
stream s = do
wVar <- asks weResp
Conc.modifyMVar_ wVar $
\wr -> return $ wr { wrRespData = Left s }
matchRequest :: Request -> [(RoutePattern, a)] -> Maybe (Captures, a)
matchRequest _ [] = Nothing
matchRequest req ((RoutePattern method pathSegs, handler):rs) =
if requestMethod req == method
then case go (pathInfo req) pathSegs H.empty of
Nothing -> matchRequest req rs
Just cs -> return (cs, handler)
else matchRequest req rs
where
go [] p h | mconcat p == "" = Just h
| otherwise = Nothing
go p [] h | mconcat p == "" = Just h
| otherwise = Nothing
go (p:ps) (l:pat) h | T.head l == ':' = go ps pat $ H.insert (T.drop 1 l) p h
| p == l = go ps pat h
| otherwise = Nothing
errorResponse404 :: WebbyM appEnv ()
errorResponse404 = setStatus status404
invalidRoutesErr :: [Char]
invalidRoutesErr = "Invalid route specification: contains duplicate routes or routes with overlapping capture patterns."
mkWebbyApp :: env -> WebbyServerConfig env -> IO Application
mkWebbyApp env wsc =
return $ mkApp
where
shortCircuitHandler =
[
E.Handler (\(ex :: FinishThrown) -> E.throwIO ex)
]
mkApp req respond = do
let defaultHandler = errorResponse404
routes = wscRoutes wsc
exceptionHandlerMay = wscExceptionHandler wsc
(cs, handler) = fromMaybe (H.empty, defaultHandler) $
matchRequest req routes
wEnv <- do v <- Conc.newMVar defaultWyResp
return $ WEnv v cs req env exceptionHandlerMay
(do runWebbyM wEnv $ handler `E.catches`
(shortCircuitHandler
<> fmap (\(WebbyExceptionHandler e) -> E.Handler e) (maybeToList exceptionHandlerMay))
webbyReply wEnv respond) `E.catches`
[
E.Handler (\(ex :: WebbyError) -> case ex of
wmc@(WebbyMissingCapture _) ->
respond $ responseLBS status404 [] $
encodeUtf8 $ displayException wmc
_ -> respond $ responseLBS status400 [] $
encodeUtf8 $ displayException ex
)
, E.Handler (\(_ :: FinishThrown) -> webbyReply wEnv respond)
]
webbyReply wEnv respond' = do
let wVar = weResp wEnv
wr <- Conc.takeMVar wVar
case wrRespData wr of
Left s -> respond' $ responseStream (wrStatus wr) (wrHeaders wr) s
Right b -> do
let clen = LB.length $ Bu.toLazyByteString b
respond' $ responseBuilder (wrStatus wr)
(wrHeaders wr ++ [(hContentLength, show clen)]) b
mkRoute :: Method -> Text -> WebbyM appEnv ()
-> (RoutePattern, WebbyM appEnv ())
mkRoute m p h =
let p' = if | T.null p -> "/"
| T.head p /= '/' -> "/" <> p
| otherwise -> p
in (RoutePattern m (drop 1 $ T.splitOn "/" p'), h)
post :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
post = mkRoute methodPost
get :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
get = mkRoute methodGet
put :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
put = mkRoute methodPut
delete :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ())
delete = mkRoute methodDelete