diff --git a/happstack-server.cabal b/happstack-server.cabal --- a/happstack-server.cabal +++ b/happstack-server.cabal @@ -1,5 +1,5 @@ Name: happstack-server -Version: 7.0.4 +Version: 7.0.5 Synopsis: Web related tools and services. Description: Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course License: BSD3 @@ -14,7 +14,7 @@ source-repository head type: darcs subdir: happstack-server - location: http://patch-tag.com/r/mae/happstack + location: http://hub.darcs.net/stepcut/happstack Flag network_2_2_3 Description: Choose newer network library with merged in network-bytestring. @@ -68,7 +68,7 @@ Paths_happstack_server Build-Depends: base >= 4 && < 5, - base64-bytestring == 0.1.*, + base64-bytestring == 1.0.*, blaze-html == 0.5.*, bytestring, containers, @@ -88,6 +88,7 @@ syb, text >= 0.10 && < 0.12, time, + threads >= 0.5, transformers >= 0.1.3 && < 0.4, transformers-base >= 0.4 && < 0.5, utf8-string >= 0.3.4 && < 0.4, diff --git a/src/Happstack/Server/Internal/Listen.hs b/src/Happstack/Server/Internal/Listen.hs --- a/src/Happstack/Server/Internal/Listen.hs +++ b/src/Happstack/Server/Internal/Listen.hs @@ -6,6 +6,7 @@ import Happstack.Server.Internal.Socket (acceptLite) import Happstack.Server.Internal.TimeoutManager (cancel, initialize, register) import Happstack.Server.Internal.TimeoutSocket as TS +import qualified Control.Concurrent.Thread.Group as TG import Control.Exception.Extensible as E import Control.Concurrent (forkIO, killThread, myThreadId) import Control.Monad @@ -84,6 +85,9 @@ #endif -} let port' = port conf + fork = case threadGroup conf of + Nothing -> forkIO + Just tg -> \m -> fst `liftM` TG.forkIO tg m tm <- initialize ((timeout conf) * (10^(6 :: Int))) -- http:// loop log' NOTICE ("Listening for http:// on port " ++ show port') @@ -97,7 +101,7 @@ cancel thandle sClose sock loop = forever $ do w <- acceptLite s - forkIO $ work w + fork $ work w pe e = log' ERROR ("ERROR in http accept thread: " ++ show e) infi :: IO () infi = loop `catchSome` pe >> infi diff --git a/src/Happstack/Server/Internal/Multipart.hs b/src/Happstack/Server/Internal/Multipart.hs --- a/src/Happstack/Server/Internal/Multipart.hs +++ b/src/Happstack/Server/Internal/Multipart.hs @@ -1,6 +1,7 @@ module Happstack.Server.Internal.Multipart where import Control.Monad (MonadPlus(mplus)) +import Data.ByteString.Base64.Lazy import qualified Data.ByteString.Lazy.Char8 as L import Data.ByteString.Lazy.Internal (ByteString(Chunk, Empty)) import qualified Data.ByteString.Lazy.UTF8 as LU @@ -10,8 +11,6 @@ import Text.ParserCombinators.Parsec (parse) import Happstack.Server.Internal.Types (Input(..)) import Happstack.Server.Internal.RFC822Headers - ( ContentType(..), ContentDisposition(..), Header - , getContentDisposition, getContentType, pHeaders) import System.IO (Handle, hClose, openBinaryTempFile) -- | similar to the normal 'span' function, except the predicate gets the whole rest of the lazy bytestring, not just one character. @@ -141,9 +140,27 @@ (HeaderResult hs cont) -> let ctype = fromMaybe defaultInputType (getContentType hs) in case getContentDisposition hs of - Just (ContentDisposition "form-data" ps) -> - cont (BodyWork ctype ps b) - + Just (ContentDisposition "form-data" ps) -> do + let eb' = case getContentTransferEncoding hs of + Nothing -> Right b + Just (ContentTransferEncoding "7bit") -> + -- We don't bother checking that the data + -- really is 7bit-only + Right b + Just (ContentTransferEncoding "8bit") -> + Right b + Just (ContentTransferEncoding "binary") -> + Right b + Just (ContentTransferEncoding "base64") -> + Right $ decodeLenient b + -- TODO: Support quoted-printable + Just cte -> + Left ("Bad content-transfer-encoding: " ++ show cte) + case eb' of + Right b' -> + cont (BodyWork ctype ps b') + Left err -> + return $ Failed Nothing err cd -> return $ Failed Nothing ("Expected content-disposition: form-data but got " ++ show cd) (BodyResult {}) -> return $ Failed Nothing "bodyPartToInput: Got unexpected BodyResult." diff --git a/src/Happstack/Server/Internal/Types.hs b/src/Happstack/Server/Internal/Types.hs --- a/src/Happstack/Server/Internal/Types.hs +++ b/src/Happstack/Server/Internal/Types.hs @@ -18,9 +18,9 @@ readDec', fromReadS, readM, FromReqURI(..) ) where - import Control.Monad.Error (Error(strMsg)) import Control.Monad.Trans (MonadIO(liftIO)) +import qualified Control.Concurrent.Thread.Group as TG import Control.Concurrent.MVar import qualified Data.Map as M import Data.Data (Data) @@ -98,19 +98,21 @@ -- | HTTP configuration data Conf = Conf - { port :: Int -- ^ Port for the server to listen on. - , validator :: Maybe (Response -> IO Response) -- ^ a function to validate the output on-the-fly - , logAccess :: forall t. FormatTime t => Maybe (LogAccess t) -- ^ function to log access requests (see also: 'logMAccess') - , timeout :: Int -- ^ number of seconds to wait before killing an inactive thread + { port :: Int -- ^ Port for the server to listen on. + , validator :: Maybe (Response -> IO Response) -- ^ a function to validate the output on-the-fly + , logAccess :: forall t. FormatTime t => Maybe (LogAccess t) -- ^ function to log access requests (see also: 'logMAccess') + , timeout :: Int -- ^ number of seconds to wait before killing an inactive thread + , threadGroup :: Maybe TG.ThreadGroup -- ^ ThreadGroup for registering spawned threads for handling requests } -- | Default configuration contains no validator and the port is set to 8000 nullConf :: Conf nullConf = - Conf { port = 8000 - , validator = Nothing - , logAccess = Just logMAccess - , timeout = 30 + Conf { port = 8000 + , validator = Nothing + , logAccess = Just logMAccess + , timeout = 30 + , threadGroup = Nothing } -- | log access requests using hslogger and apache-style log formatting diff --git a/tests/Test.hs b/tests/Test.hs deleted file mode 100644 --- a/tests/Test.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Main where - -import Happstack.Server.Tests (allTests) -import Test.HUnit (errors, failures, putTextToShowS,runTestText, runTestTT) -import System.Exit (exitFailure) -import System.IO (hIsTerminalDevice, stdout) - --- |A simple driver for running the local test suite. -main :: IO () -main = - do c <- do istty <- hIsTerminalDevice stdout - if istty - then runTestTT allTests - else do (c,st) <- runTestText putTextToShowS allTests - putStrLn (st "") - return c - case (failures c) + (errors c) of - 0 -> return () - _ -> exitFailure