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 qualified UnliftIO.Concurrent as Conc
import qualified UnliftIO.Exception as E
import Web.HttpApiData
import Webby.Types
import Prelude
asksWEnv :: (WEnv appEnv -> a) -> WebbyM appEnv a
asksWEnv getter = WebbyM $ lift $ asks getter
captures :: WebbyM appEnv Captures
captures = asksWEnv 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 <- asksWEnv weResp
Conc.modifyMVar_ wVar $ \wr -> return $ wr {wrStatus = sts}
addHeader :: Header -> WebbyM appEnv ()
addHeader h = do
wVar <- asksWEnv weResp
Conc.modifyMVar_ wVar $
\wr -> do
let hs = wrHeaders wr
return $ wr {wrHeaders = hs ++ [h]}
setHeader :: Header -> WebbyM appEnv ()
setHeader (k, v) = do
wVar <- asksWEnv 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 = asksWEnv weRequest
getRequestBodyChunkAction :: WebbyM appEnv (WebbyM appEnv ByteString)
getRequestBodyChunkAction = (liftIO . getRequestBodyChunk) <$> asksWEnv 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 <- asksWEnv 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 <- asksWEnv 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 <- asksWEnv weResp
Conc.modifyMVar_ wVar $
\wr ->
return $
wr
{ wrRespData =
Right $
Bu.fromLazyByteString $
A.encode j
}
stream :: StreamingBody -> WebbyM appEnv ()
stream s = do
wVar <- asksWEnv 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