Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Make maximum POST body size configurable #40

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Make maximum POST body size configurable #40

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions src/Snap/Http/Server.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -83,6 +83,7 @@ simpleHttpServe config handler = do
($ dat)
(getStartupHook conf))
(runSnap handler)
(fromJust $ getMaxPOSTBodySize conf)

--------------------------------------------------------------------------
mkStartupInfo sockets conf =
Expand Down
2 changes: 2 additions & 0 deletions src/Snap/Http/Server/Config.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -35,6 +35,7 @@ module Snap.Http.Server.Config
, getSSLPort
, getVerbose
, getStartupHook
, getMaxPOSTBodySize

, setAccessLog
, setBind
Expand All @@ -53,6 +54,7 @@ module Snap.Http.Server.Config
, setSSLPort
, setVerbose
, setStartupHook
, setMaxPOSTBodySize
, StartupInfo
, getStartupSockets
, getStartupConfig
Expand Down
28 changes: 16 additions & 12 deletions src/Snap/Internal/Http/Server.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -128,6 +128,7 @@ data ServerState = ServerState
, _sessionPort :: SessionInfo
, _logAccess :: Request -> Response -> IO ()
, _logError :: ByteString -> IO ()
, _maxPOSTBodySize :: Int64
}


Expand All @@ -137,10 +138,11 @@ runServerMonad :: ByteString -- ^ local host name
-> (Request -> Response -> IO ()) -- ^ access log function
-> (ByteString -> IO ()) -- ^ error log function
-> ServerMonad a -- ^ monadic action to run
-> Int64 -- ^ maximum POST body size
-> Iteratee ByteString IO a
runServerMonad lh s la le m = evalStateT m st
runServerMonad lh s la le m mpbs = evalStateT m st
where
st = ServerState False lh s la le
st = ServerState False lh s la le mpbs


------------------------------------------------------------------------------
Expand All @@ -155,8 +157,9 @@ httpServe :: Int -- ^ default timeout
-> Maybe (ByteString -> IO ()) -- ^ error log action
-> ([Socket] -> IO ()) -- ^ initialisation
-> ServerHandler -- ^ handler procedure
-> Int64 -- ^ maximum post body size
-> IO ()
httpServe defaultTimeout ports localHostname alog' elog' initial handler =
httpServe defaultTimeout ports localHostname alog' elog' initial handler mpbs =
withSocketsDo $ spawnAll alog' elog' `catches` errorHandlers

where
Expand Down Expand Up @@ -207,7 +210,7 @@ httpServe defaultTimeout ports localHostname alog' elog' initial handler =
let socks = map (\x -> case x of ListenHttp s -> s; ListenHttps s _ -> s) nports

(simpleEventLoop defaultTimeout nports numCapabilities (logE elog) (initial socks)
$ runHTTP defaultTimeout alog elog handler localHostname)
$ runHTTP defaultTimeout alog elog handler localHostname mpbs)
`finally` do
logE elog "Server.httpServe: SHUTDOWN"

Expand Down Expand Up @@ -273,14 +276,15 @@ runHTTP :: Int -- ^ default timeout
-> Maybe (ByteString -> IO ()) -- ^ error logger
-> ServerHandler -- ^ handler procedure
-> ByteString -- ^ local host name
-> Int64 -- ^ maximum POST body size
-> SessionInfo -- ^ session port information
-> Enumerator ByteString IO () -- ^ read end of socket
-> Iteratee ByteString IO () -- ^ write end of socket
-> (FilePath -> Int64 -> Int64 -> IO ())
-- ^ sendfile end
-> ((Int -> Int) -> IO ()) -- ^ timeout tickler
-> IO ()
runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile
runHTTP defaultTimeout alog elog handler lh mpbs sinfo readEnd writeEnd onSendFile
tickle =
go `catches` [ Handler $ \(_ :: TerminatedBeforeHandlerException) -> do
return ()
Expand All @@ -304,9 +308,11 @@ runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile

go = do
buf <- allocBuffer 16384
let iter1 = runServerMonad lh sinfo (logA alog) (logE elog) $
httpSession defaultTimeout writeEnd buf
onSendFile tickle handler
let iter1 = runServerMonad lh sinfo (logA alog) (logE elog)
(httpSession defaultTimeout writeEnd buf
onSendFile tickle handler)
mpbs

let iter = iterateeDebugWrapper "httpSession iteratee" iter1

debug "runHTTP/go: prepping iteratee for start"
Expand Down Expand Up @@ -615,19 +621,17 @@ receiveRequest writeEnd = do
mbCT' = liftM trimIt mbCT
doIt = mbCT' == Just "application/x-www-form-urlencoded"

maximumPOSTBodySize :: Int64
maximumPOSTBodySize = 10*1024*1024

getIt :: ServerMonad Request
getIt = {-# SCC "receiveRequest/parseForm/getIt" #-} do
debug "parseForm: got application/x-www-form-urlencoded"
debug "parseForm: reading POST body"
senum <- liftIO $ readIORef $ rqBody req
mpbs <- gets _maxPOSTBodySize
let (SomeEnumerator enum) = senum
consumeStep <- liftIO $ runIteratee consume
step <- liftIO $
runIteratee $
joinI $ takeNoMoreThan maximumPOSTBodySize consumeStep
joinI $ takeNoMoreThan mpbs consumeStep
body <- liftM S.concat $ lift $ enum step
let newParams = parseUrlEncoded body

Expand Down
141 changes: 75 additions & 66 deletions src/Snap/Internal/Http/Server/Config.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -20,6 +20,7 @@ import Control.Monad
import qualified Data.ByteString.Char8 as B
import Data.ByteString (ByteString)
import Data.Char
import Data.Int
import Data.Function
import Data.List
import Data.Maybe
Expand Down Expand Up @@ -78,24 +79,25 @@ instance Show ConfigLog where
-- Any fields which are unspecified in the 'Config' passed to 'httpServe' (and
-- this is the norm) are filled in with default values from 'defaultConfig'.
data Config m a = Config
{ hostname :: Maybe ByteString
, accessLog :: Maybe ConfigLog
, errorLog :: Maybe ConfigLog
, locale :: Maybe String
, port :: Maybe Int
, bind :: Maybe ByteString
, sslport :: Maybe Int
, sslbind :: Maybe ByteString
, sslcert :: Maybe FilePath
, sslkey :: Maybe FilePath
, compression :: Maybe Bool
, verbose :: Maybe Bool
, errorHandler :: Maybe (SomeException -> m ())
, defaultTimeout :: Maybe Int
, other :: Maybe a
, backend :: Maybe ConfigBackend
, proxyType :: Maybe ProxyType
, startupHook :: Maybe (StartupInfo m a -> IO ())
{ hostname :: Maybe ByteString
, accessLog :: Maybe ConfigLog
, errorLog :: Maybe ConfigLog
, locale :: Maybe String
, port :: Maybe Int
, bind :: Maybe ByteString
, sslport :: Maybe Int
, sslbind :: Maybe ByteString
, sslcert :: Maybe FilePath
, sslkey :: Maybe FilePath
, compression :: Maybe Bool
, verbose :: Maybe Bool
, errorHandler :: Maybe (SomeException -> m ())
, defaultTimeout :: Maybe Int
, other :: Maybe a
, backend :: Maybe ConfigBackend
, proxyType :: Maybe ProxyType
, startupHook :: Maybe (StartupInfo m a -> IO ())
, maxPOSTBodySize :: Maybe Int64
}
#if MIN_VERSION_base(4,7,0)
deriving (Typeable)
Expand Down Expand Up @@ -148,45 +150,47 @@ emptyConfig = mempty
------------------------------------------------------------------------------
instance Monoid (Config m a) where
mempty = Config
{ hostname = Nothing
, accessLog = Nothing
, errorLog = Nothing
, locale = Nothing
, port = Nothing
, bind = Nothing
, sslport = Nothing
, sslbind = Nothing
, sslcert = Nothing
, sslkey = Nothing
, compression = Nothing
, verbose = Nothing
, errorHandler = Nothing
, defaultTimeout = Nothing
, other = Nothing
, backend = Nothing
, proxyType = Nothing
, startupHook = Nothing
{ hostname = Nothing
, accessLog = Nothing
, errorLog = Nothing
, locale = Nothing
, port = Nothing
, bind = Nothing
, sslport = Nothing
, sslbind = Nothing
, sslcert = Nothing
, sslkey = Nothing
, compression = Nothing
, verbose = Nothing
, errorHandler = Nothing
, defaultTimeout = Nothing
, other = Nothing
, backend = Nothing
, proxyType = Nothing
, startupHook = Nothing
, maxPOSTBodySize = Nothing
}

a `mappend` b = Config
{ hostname = ov hostname
, accessLog = ov accessLog
, errorLog = ov errorLog
, locale = ov locale
, port = ov port
, bind = ov bind
, sslport = ov sslport
, sslbind = ov sslbind
, sslcert = ov sslcert
, sslkey = ov sslkey
, compression = ov compression
, verbose = ov verbose
, errorHandler = ov errorHandler
, defaultTimeout = ov defaultTimeout
, other = ov other
, backend = ov backend
, proxyType = ov proxyType
, startupHook = ov startupHook
{ hostname = ov hostname
, accessLog = ov accessLog
, errorLog = ov errorLog
, locale = ov locale
, port = ov port
, bind = ov bind
, sslport = ov sslport
, sslbind = ov sslbind
, sslcert = ov sslcert
, sslkey = ov sslkey
, compression = ov compression
, verbose = ov verbose
, errorHandler = ov errorHandler
, defaultTimeout = ov defaultTimeout
, other = ov other
, backend = ov backend
, proxyType = ov proxyType
, startupHook = ov startupHook
, maxPOSTBodySize = ov maxPOSTBodySize
}
where
ov f = getLast $! (mappend `on` (Last . f)) a b
Expand All @@ -212,18 +216,19 @@ instance (Typeable1 m) => Typeable1 (Config m) where
-- | These are the default values for the options
defaultConfig :: MonadSnap m => Config m a
defaultConfig = mempty
{ hostname = Just "localhost"
, accessLog = Just $ ConfigFileLog "log/access.log"
, errorLog = Just $ ConfigFileLog "log/error.log"
, locale = Just "en_US"
, compression = Just True
, verbose = Just True
, errorHandler = Just defaultErrorHandler
, bind = Just "0.0.0.0"
, sslbind = Just "0.0.0.0"
, sslcert = Just "cert.pem"
, sslkey = Just "key.pem"
, defaultTimeout = Just 60
{ hostname = Just "localhost"
, accessLog = Just $ ConfigFileLog "log/access.log"
, errorLog = Just $ ConfigFileLog "log/error.log"
, locale = Just "en_US"
, compression = Just True
, verbose = Just True
, errorHandler = Just defaultErrorHandler
, bind = Just "0.0.0.0"
, sslbind = Just "0.0.0.0"
, sslcert = Just "cert.pem"
, sslkey = Just "key.pem"
, defaultTimeout = Just 60
, maxPOSTBodySize = Just (10*1024*1024)
}


Expand Down Expand Up @@ -304,6 +309,8 @@ getProxyType = proxyType
getStartupHook :: Config m a -> Maybe (StartupInfo m a -> IO ())
getStartupHook = startupHook

getMaxPOSTBodySize :: Config m a -> Maybe Int64
getMaxPOSTBodySize = maxPOSTBodySize

------------------------------------------------------------------------------
setHostname :: ByteString -> Config m a -> Config m a
Expand Down Expand Up @@ -360,6 +367,8 @@ setProxyType x c = c { proxyType = Just x }
setStartupHook :: (StartupInfo m a -> IO ()) -> Config m a -> Config m a
setStartupHook x c = c { startupHook = Just x }

setMaxPOSTBodySize :: Int64 -> Config m a -> Config m a
setMaxPOSTBodySize x c = c { maxPOSTBodySize = Just x }

------------------------------------------------------------------------------

Expand Down