happstack-server 7.0.4 → 7.0.5
raw patch · 5 files changed
+42/−37 lines, 5 filesdep +threadsdep ~base64-bytestring
Dependencies added: threads
Dependency ranges changed: base64-bytestring
Files
- happstack-server.cabal +4/−3
- src/Happstack/Server/Internal/Listen.hs +5/−1
- src/Happstack/Server/Internal/Multipart.hs +22/−5
- src/Happstack/Server/Internal/Types.hs +11/−9
- tests/Test.hs +0/−19
happstack-server.cabal view
@@ -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 <http://happstack.com/docs/crashcourse/index.html> 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,
src/Happstack/Server/Internal/Listen.hs view
@@ -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
src/Happstack/Server/Internal/Multipart.hs view
@@ -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."
src/Happstack/Server/Internal/Types.hs view
@@ -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
− tests/Test.hs
@@ -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