Something went wrong. Try again.
A Haskell Webserver Template
Something went wrong. Try again.
2.9 kB · 78 lines
Haskell
at main
12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879module Webserver.Control.Body ( readJsonBody, readJsonBodyWith, readRawBody,)where
----------------------------------------------------------------------------------------------------
import Data.Aeson (FromJSON)import qualified Data.Aeson as Aesonimport Data.ByteString (ByteString)import qualified Data.ByteString as BSimport Data.List (lookup, reverse)import Data.Word (Word8)import qualified Network.HTTP.Types as Httpimport qualified Network.Wai as Waiimport Webserver.Data.BodyError (BodyError (..), defaultMaxBodySize)
----------------------------------------------------------------------------------------------------
-- | Read and decode a JSON request body, enforcing Content-Type and a 1 MiB size limitreadJsonBody :: (FromJSON a) => Wai.Request -> IO (Either BodyError a)readJsonBody = readJsonBodyWith defaultMaxBodySize
-- | Read and decode a JSON request body with a custom size limitreadJsonBodyWith :: (FromJSON a) => Int -> Wai.Request -> IO (Either BodyError a)readJsonBodyWith maxSize request = if not (isJsonContentType request) then return <| Left UnsupportedContentType else readRawBody maxSize request >>= \case Left err -> return <| Left err Right bytes -> case Aeson.decodeStrict bytes of Nothing -> return <| Left DecodeFailed Just val -> return <| Right val
-- | Read all chunks from a request body into a single strict ByteString, enforcing a size limitreadRawBody :: Int -> Wai.Request -> IO (Either BodyError ByteString)readRawBody maxSize request = let accumulate :: [ByteString] -> Int -> IO (Either BodyError ByteString) accumulate acc accSize = do chunk <- Wai.getRequestBodyChunk request if BS.null chunk then return <| Right (BS.concat (reverse acc)) else let newSize = accSize + BS.length chunk in if newSize > maxSize then return <| Left BodyTooLarge else accumulate (chunk : acc) newSize in accumulate [] 0
----------------------------------------------------------------------------------------------------
-- | Check whether a request's Content-Type header indicates application/jsonisJsonContentType :: Wai.Request -> BoolisJsonContentType request = case lookup Http.hContentType (Wai.requestHeaders request) of Nothing -> False Just ct -> let mediaType = ct |> BS.takeWhile (/= semicolon) |> BS.dropWhileEnd (== space) |> BS.map toLowerByte in mediaType == "application/json"
toLowerByte :: Word8 -> Word8toLowerByte w | w >= 0x41 && w <= 0x5A = w + 32 | otherwise = w
semicolon :: Word8semicolon = 0x3B
space :: Word8space = 0x20