happstack-server 6.5.7 → 6.6.2
raw patch · 15 files changed
+95/−265 lines, 15 filesdep −HsOpenSSL
Dependencies removed: HsOpenSSL
Files
- happstack-server.cabal +5/−19
- src/Happstack/Server/Internal/Cookie.hs +1/−1
- src/Happstack/Server/Internal/Handler.hs +8/−7
- src/Happstack/Server/Internal/Listen.hs +5/−57
- src/Happstack/Server/Internal/MessageWrap.hs +1/−1
- src/Happstack/Server/Internal/Multipart.hs +3/−1
- src/Happstack/Server/Internal/RFC822Headers.hs +3/−3
- src/Happstack/Server/Internal/TLS.hs +0/−67
- src/Happstack/Server/Internal/TimeoutSocketTLS.hs +0/−60
- src/Happstack/Server/Internal/Types.hs +24/−18
- src/Happstack/Server/Response.hs +5/−1
- src/Happstack/Server/SURI.hs +3/−2
- src/Happstack/Server/SimpleHTTP.hs +4/−6
- src/Happstack/Server/Types.hs +1/−1
- tests/Happstack/Server/Tests.hs +32/−21
happstack-server.cabal view
@@ -1,5 +1,5 @@ Name: happstack-server-Version: 6.5.7+Version: 6.6.2 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@@ -27,11 +27,6 @@ Description: Build the testsuite, and include the tests in the library Default: False -Flag https- Description: Compile server with https:// support- Default: True- Manual: True- Library Exposed-modules:@@ -46,10 +41,13 @@ Happstack.Server.I18N Happstack.Server.Internal.Compression Happstack.Server.Internal.Cookie+ Happstack.Server.Internal.Handler Happstack.Server.Internal.Types+ Happstack.Server.Internal.Listen Happstack.Server.Internal.LowLevel Happstack.Server.Internal.MessageWrap- Happstack.Server.Internal.TLS+ Happstack.Server.Internal.Multipart+ Happstack.Server.Internal.Socket Happstack.Server.Internal.TimeoutIO Happstack.Server.Internal.TimeoutManager Happstack.Server.Internal.TimeoutSocket@@ -71,13 +69,9 @@ Happstack.Server.HTTPClient.Stream Happstack.Server.HTTPClient.TCP Happstack.Server.Internal.Clock- Happstack.Server.Internal.Handler Happstack.Server.Internal.LazyLiner- Happstack.Server.Internal.Listen Happstack.Server.Internal.LogFormat- Happstack.Server.Internal.Multipart Happstack.Server.Internal.RFC822Headers- Happstack.Server.Internal.Socket Happstack.Server.Internal.SocketTH Happstack.Server.SURI.ParseURI Paths_happstack_server@@ -107,14 +101,6 @@ utf8-string >= 0.3.4 && < 0.4, xhtml, zlib- if flag(https)- Exposed-modules:- Happstack.Server.Internal.TimeoutSocketTLS- Build-Depends:- HsOpenSSL == 0.10.*- Extra-Libraries: cryptopp ssl- else- CPP-Options: -DDISABLE_HTTPS if flag(network_2_2_3) Build-Depends: network >= 2.2.3
src/Happstack/Server/Internal/Cookie.hs view
@@ -139,7 +139,7 @@ cookieEq = ws >> char '=' >> ws ws = spaces value = word- word = try (quoted_string) <|> incomp_token+ word = try quoted_string <|> try incomp_token <|> return "" -- Parsers based on RFC 2068 quoted_string = do
src/Happstack/Server/Internal/Handler.hs view
@@ -14,6 +14,7 @@ import Data.List(elemIndex) import Data.Char(toLower) import Data.Maybe ( fromMaybe, fromJust, isJust, isNothing )+import Data.Time (UTCTime) import Prelude hiding (last) import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.Char8 as B@@ -37,21 +38,21 @@ import System.IO import System.IO.Error (isDoesNotExistError) -request :: TimeoutIO -> Conf -> Host -> (Request -> IO Response) -> IO ()-request timeoutIO conf host handler =- rloop timeoutIO conf host handler =<< toGetContents timeoutIO+request :: TimeoutIO -> Maybe (LogAccess UTCTime) -> Host -> (Request -> IO Response) -> IO ()+request timeoutIO mlog host handler =+ rloop timeoutIO mlog host handler =<< toGetContents timeoutIO required :: String -> Maybe a -> Either String a required err Nothing = Left err required _ (Just a) = Right a rloop :: TimeoutIO- -> Conf+ -> Maybe (LogAccess UTCTime) -> Host -> (Request -> IO Response) -> L.ByteString -> IO ()-rloop timeoutIO conf host handler inputStr+rloop timeoutIO mlog host handler inputStr | L.null inputStr = return () | otherwise = join $@@ -84,7 +85,7 @@ res <- ioseq (handler req) `E.catch` \(e::E.SomeException) -> return $ result 500 $ "Server error: " ++ show e - case logAccess conf of+ case mlog of Nothing -> return () (Just logger) -> do time <- getApproximateUTCTime@@ -101,7 +102,7 @@ putAugmentedResult timeoutIO req res -- clean up tmp files cleanupTempFiles req- when (continueHTTP req res) $ rloop timeoutIO conf host handler nextRequest+ when (continueHTTP req res) $ rloop timeoutIO mlog host handler nextRequest -- NOTE: if someone took the inputs and never put them back, then they are responsible for the cleanup cleanupTempFiles :: Request -> IO ()
src/Happstack/Server/Internal/Listen.hs view
@@ -4,19 +4,11 @@ import Happstack.Server.Internal.Types (Conf(..), Request, Response) import Happstack.Server.Internal.Handler (request) import Happstack.Server.Internal.Socket (acceptLite)-import Happstack.Server.Internal.TimeoutIO (TimeoutIO(toHandle, toShutdown)) import Happstack.Server.Internal.TimeoutManager (cancel, initialize, register) import Happstack.Server.Internal.TimeoutSocket as TS-#ifdef DISABLE_HTTPS-import Happstack.Server.Internal.TLS (HTTPS)-#else-import Happstack.Server.Internal.TimeoutSocketTLS as TSS-import Happstack.Server.Internal.TLS (HTTPS, TLSConf(..), acceptTLS, httpsOnSocket)-#endif import Control.Exception.Extensible as E import Control.Concurrent (forkIO, killThread, myThreadId) import Control.Monad (forever, when)-import Data.Maybe (fromJust) import Network.BSD (getProtocolNumber) import Network (sClose, Socket) import Network.Socket as Socket (SocketOption(KeepAlive), setSocketOption, @@ -25,10 +17,6 @@ iNADDR_ANY, maxListenQueue, SocketType(..), bindSocket) import qualified Network.Socket as Socket (listen, inet_addr)-#ifndef DISABLE_HTTPS-import qualified OpenSSL as SSL-import qualified OpenSSL.Session as SSL-#endif import System.IO.Error (isFullError) {- #ifndef mingw32_HOST_OS@@ -83,22 +71,11 @@ let port' = port conf socketm <- listenOn port' setSocketOption socketm KeepAlive 1- mHTTPS <- case tls conf of- Nothing -> return Nothing- (Just tlsConf) ->-#ifdef DISABLE_HTTPS- do return Nothing-#else- do SSL.withOpenSSL $ return ()- tlsSocket <- listenOn (tlsPort tlsConf)- https <- httpsOnSocket (tlsCert tlsConf) (tlsKey tlsConf) tlsSocket- return (Just https)-#endif- listen' socketm mHTTPS conf hand+ listen' socketm conf hand -- | Use a previously bind port and listen-listen' :: Socket -> Maybe HTTPS -> Conf -> (Request -> IO Response) -> IO ()-listen' s mhttps conf hand = do+listen' :: Socket -> Conf -> (Request -> IO Response) -> IO ()+listen' s conf hand = do {- #ifndef mingw32_HOST_OS -}@@ -108,35 +85,6 @@ -} let port' = port conf tm <- initialize ((timeout conf) * (10^(6 :: Int)))- -- https:// loop- httpsTid <- forkIO $- case mhttps of- Nothing -> return ()-#ifdef DISABLE_HTTPS- (Just _) -> - do log' ERROR ("Ignoring https:// configuration because happstack-server was compiled with disable_https")-#else- (Just https) -> - do let ehs (x::SomeException) = when ((fromException x) /= Just ThreadKilled) $ log' ERROR ("HTTPS request failed with: " ++ show x)- work (ssl, hn, p) = - do tid <- myThreadId- thandle <- register tm (killThread tid)- let timeoutIO = TSS.timeoutSocketIO thandle ssl- request timeoutIO conf (hn,fromIntegral p) hand `E.catch` ehs- -- remove thread from timeout table- cancel (toHandle timeoutIO)- toShutdown timeoutIO- loop = forever ((do w <- acceptTLS https- forkIO $ work w- return ())- `E.catch` sslException)- sslException :: SSL.SomeSSLException -> IO ()- sslException e = log' ERROR ("SSL exception in https accept thread: " ++ show e)- pe e = log' ERROR ("ERROR in https accept thread: " ++ show e)- infi = loop `catchSome` pe >> infi- log' NOTICE ("Listening for https:// on port " ++ show (tlsPort $ fromJust (tls conf)))- infi `finally` (sClose s)-#endif -- http:// loop log' NOTICE ("Listening for http:// on port " ++ show port') let eh (x::SomeException) = when ((fromException x) /= Just ThreadKilled) $ log' ERROR ("HTTP request failed with: " ++ show x)@@ -144,7 +92,7 @@ do tid <- myThreadId thandle <- register tm (killThread tid) let timeoutIO = TS.timeoutSocketIO thandle sock- request timeoutIO conf (hn,fromIntegral p) hand `E.catch` eh+ request timeoutIO (logAccess conf) (hn,fromIntegral p) hand `E.catch` eh -- remove thread from timeout table cancel thandle sClose sock@@ -153,7 +101,7 @@ pe e = log' ERROR ("ERROR in http accept thread: " ++ show e) infi = loop `catchSome` pe >> infi - infi `finally` (sClose s >> killThread httpsTid)+ infi `finally` (sClose s) {-- #ifndef mingw32_HOST_OS
src/Happstack/Server/Internal/MessageWrap.hs view
@@ -77,7 +77,7 @@ formDecode [] = [] formDecode qString = if null pairString then rest else - (SURI.unEscape name,simpleInput $ SURI.unEscape val):rest+ (SURI.unEscapeQS name,simpleInput $ SURI.unEscapeQS val):rest where (pairString,qString')= split (=='&') qString (name,val)=split (=='=') pairString rest=if null qString' then [] else formDecode qString'
src/Happstack/Server/Internal/Multipart.hs view
@@ -235,7 +235,9 @@ splitBoundary :: L.ByteString -> L.ByteString -> (L.ByteString, L.ByteString) splitBoundary boundary s = case spanS (not . L.isPrefixOf (L.pack "\r\n--" `L.append` boundary)) s of- (x,y) -> (x, dropLine (L.drop 2 y))+ (x,y) | (L.pack "\r\n--" `L.append` boundary `L.append` (L.pack "--"))+ `L.isPrefixOf` y -> (x, L.empty)+ | otherwise -> (x, dropLine (L.drop 2 y)) {-# INLINE splitBoundary #-} splitAtEmptyLine :: L.ByteString -> Maybe (L.ByteString, L.ByteString)
src/Happstack/Server/Internal/RFC822Headers.hs view
@@ -248,9 +248,9 @@ headerNameChar :: Parser Char headerNameChar = noneOf "\n\r:" -especials, tokenchar :: [Char]-especials = "()<>@,;:\\\"/[]?.="-tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials+tspecials, tokenchar :: [Char]+tspecials = "()<>@,;:\\\"/[]?=" -- RFC2045+tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ tspecials p_token :: Parser String p_token = many1 (oneOf tokenchar)
− src/Happstack/Server/Internal/TLS.hs
@@ -1,67 +0,0 @@-{-# LANGUAGE CPP #-}-{- | core functions and types for HTTPS support--}-module Happstack.Server.Internal.TLS where--#ifdef DISABLE_HTTPS-import Network.Socket (Socket)-#else-import Control.Monad (when)-import Happstack.Server.Internal.Socket (acceptLite)-import Network.Socket (HostName, PortNumber, Socket)-import OpenSSL.Session (SSL, SSLContext)-import qualified OpenSSL.Session as SSL-#endif---- | configuration for using https:\/\/-data TLSConf = TLSConf {- tlsPort :: Int -- port (usually 443)- , tlsCert :: FilePath -- path to SSL certificate- , tlsKey :: FilePath -- path to SSL private key- }--#ifdef DISABLE_HTTPS-data HTTPS = HTTPS-httpsOnSocket :: FilePath -- ^ path to ssl certificate- -> FilePath -- ^ path to ssl private key- -> Socket -- ^ listening socket (on which listen() has been called, but not accept())- -> IO HTTPS-httpsOnSocket = error "happstack-server was compiled with disable_https."-#else--- | record that holds the 'Socket' and 'SSLContext' needed to start--- the https:\/\/ event loop. Used with 'simpleHTTPWithSocket''------ see also: 'httpOnSocket'-data HTTPS = HTTPS- { httpsSocket :: Socket- , sslContext :: SSLContext- }---- | generate the 'HTTPS' record needed to start the https:\/\/ event loop----httpsOnSocket :: FilePath -- ^ path to ssl certificate- -> FilePath -- ^ path to ssl private key- -> Socket -- ^ listening socket (on which listen() has been called, but not accept())- -> IO HTTPS-httpsOnSocket cert key socket =- do ctx <- SSL.context- SSL.contextSetPrivateKeyFile ctx key- SSL.contextSetCertificateFile ctx cert- SSL.contextSetDefaultCiphers ctx-- b <- SSL.contextCheckPrivateKey ctx- when (not b) $ error $ "OpenTLS certificate and key do not match."-- return (HTTPS socket ctx)--acceptTLS :: HTTPS -> IO (SSL, HostName, PortNumber)-acceptTLS (HTTPS sck' ctx) =- do -- do normal accept- (sck, peer, port) <- acceptLite sck'-- -- then TLS accept- ssl <- SSL.connection ctx sck- SSL.accept ssl-- return (ssl, peer, port)-#endif
− src/Happstack/Server/Internal/TimeoutSocketTLS.hs
@@ -1,60 +0,0 @@-{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}-{- | --- borrowed from snap-server. Check there periodically for updates.--}-module Happstack.Server.Internal.TimeoutSocketTLS where--import Control.Monad (liftM)-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Lazy.Internal as L-import qualified Data.ByteString as S-import qualified Happstack.Server.Internal.TimeoutManager as TM-import Happstack.Server.Internal.TimeoutIO (TimeoutIO(..))-import Network.Socket.SendFile (ByteCount, Offset)-import OpenSSL.Session (SSL)-import qualified OpenSSL.Session as SSL-import Prelude hiding (catch)-import System.IO (IOMode(ReadMode), SeekMode(AbsoluteSeek), hSeek, withBinaryFile)-import System.IO.Unsafe (unsafeInterleaveIO)--sPutLazyTickle :: TM.Handle -> SSL -> L.ByteString -> IO ()-sPutLazyTickle thandle ssl cs =- do L.foldrChunks (\c rest -> SSL.write ssl c >> TM.tickle thandle >> rest) (return ()) cs-{-# INLINE sPutLazyTickle #-}--sPutTickle :: TM.Handle -> SSL -> B.ByteString -> IO ()-sPutTickle thandle ssl cs =- do SSL.write ssl cs- TM.tickle thandle-{-# INLINE sPutTickle #-}--sGetContents :: TM.Handle - -> SSL -- ^ Connected socket- -> IO L.ByteString -- ^ Data received-sGetContents handle ssl = loop where- loop = unsafeInterleaveIO $ do- s <- SSL.read ssl 65536- TM.tickle handle- if S.null s- then do -- SSL.shutdown ssl SSL.Unidirectional `catch` (\e -> when (not $ isDoesNotExistError e) (throw e))- return L.Empty- else L.Chunk s `liftM` loop--timeoutSocketIO :: TM.Handle -> SSL -> TimeoutIO-timeoutSocketIO handle ssl =- TimeoutIO { toHandle = handle- , toShutdown = SSL.shutdown ssl SSL.Bidirectional- , toPutLazy = sPutLazyTickle handle ssl- , toPut = sPutTickle handle ssl- , toGetContents = sGetContents handle ssl- , toSendFile = sendFileTickle handle ssl- , toSecure = True- }--sendFileTickle :: TM.Handle -> SSL -> FilePath -> Offset -> ByteCount -> IO ()-sendFileTickle thandle ssl fp offset count =- do withBinaryFile fp ReadMode $ \h -> do- hSeek h AbsoluteSeek offset- c <- L.hGetContents h- sPutLazyTickle thandle ssl (L.take (fromIntegral count) c)
src/Happstack/Server/Internal/Types.hs view
@@ -9,7 +9,7 @@ setHeader, setHeaderBS, setHeaderUnsafe, addHeader, addHeaderBS, addHeaderUnsafe, setRsCode, -- setCookie, setCookies,- Conf(..), nullConf, TLSConf(..), HTTPS(..), result, resultBS,+ LogAccess, logMAccess, Conf(..), nullConf, result, resultBS, redirect, -- redirect_, redirect', redirect'_, isHTTP1_0, isHTTP1_1, RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength,@@ -24,9 +24,11 @@ import Control.Concurrent.MVar import qualified Data.Map as M import Data.Data (Data)+import Data.String (fromString) import Data.Time.Format (FormatTime(..)) import Data.Typeable(Typeable) import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.UTF8 as U (toString) import Data.ByteString.Char8 (ByteString,pack) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.UTF8 as LU (fromString)@@ -34,12 +36,13 @@ import Data.Maybe import Data.List import Data.Word (Word, Word8, Word16, Word32, Word64)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as Lazy import Happstack.Server.SURI import Data.Char (toLower) import Happstack.Server.Internal.RFC822Headers ( ContentType(..) ) import Happstack.Server.Internal.Cookie import Happstack.Server.Internal.LogFormat (formatRequestCombined)-import Happstack.Server.Internal.TLS import Numeric (readDec, readSigned) import System.Log.Logger (Priority(..), logM) import Text.Show.Functions ()@@ -72,20 +75,30 @@ (isHTTP1_0 rq && checkHeaderBS connectionC keepaliveC rq && rsfLength (rsFlags res) == ContentLength) || (isHTTP1_1 rq && not (checkHeaderBS connectionC closeC rq) && rsfLength (rsFlags res) /= NoContentLength) +-- | function to log access requests (see also: 'logMAccess')+type LogAccess time =+ ( String -- ^ host+ -> String -- ^ user+ -> time -- ^ time+ -> String -- ^ requestLine+ -> Int -- ^ responseCode+ -> Integer -- ^ size+ -> String -- ^ referer+ -> String -- ^ userAgent+ -> IO ()) + -- | HTTP configuration data Conf = Conf- { port :: Int -- ^ Port for the server to listen on.- , tls :: Maybe TLSConf+ { 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 (String -> String -> t -> String -> Int -> Integer -> String -> String -> IO ()) -- ^ function to log access requests (see also: 'logMAccess')- , timeout :: Int -- ^ number of seconds to wait before killing an inactive thread+ , 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 } -- | Default configuration contains no validator and the port is set to 8000 nullConf :: Conf nullConf = Conf { port = 8000- , tls = Nothing , validator = Nothing , logAccess = Just logMAccess , timeout = 30@@ -94,16 +107,7 @@ -- | log access requests using hslogger and apache-style log formatting -- -- see also: 'Conf'-logMAccess :: forall t. FormatTime t =>- String -- ^ host- -> String -- ^ user- -> t -- ^ time- -> String -- ^ requestLine- -> Int -- ^ responseCode- -> Integer -- ^ size- -> String -- ^ referer- -> String -- ^ userAgent- -> IO ()+logMAccess :: forall t. FormatTime t => LogAccess t logMAccess host user time requestLine responseCode size referer userAgent = logM "Happstack.Server.AccessLog.Combined" INFO $ formatRequestCombined host user time requestLine responseCode size referer userAgent @@ -450,7 +454,9 @@ class FromReqURI a where fromReqURI :: String -> Maybe a -instance FromReqURI String where fromReqURI = Just+instance FromReqURI String where fromReqURI = Just . U.toString . P.pack+instance FromReqURI Text.Text where fromReqURI = fmap fromString . fromReqURI+instance FromReqURI Lazy.Text where fromReqURI = fmap fromString . fromReqURI instance FromReqURI Char where fromReqURI s = case s of [c] -> Just c ; _ -> Nothing instance FromReqURI Int where fromReqURI = fromReadS . readSigned readDec instance FromReqURI Int8 where fromReqURI = fromReadS . readSigned readDec
src/Happstack/Server/Response.hs view
@@ -70,7 +70,7 @@ -- | 'toResponse' will convert a value into a 'Response' body, -- set the @content-type@, and set the default response code for that type. ----- Example:+-- @happstack-server@ Example: -- -- > main = simpleHTTP nullConf $ toResponse "hello, world!" --@@ -80,6 +80,10 @@ -- 'simpleHTTP' will call 'toResponse' automatically, so the above can be shortened to: -- -- > main = simpleHTTP nullConf $ "hello, world!"+--+-- @happstack-lite@ Example:+--+-- > main = serve Nothing $ toResponse "hello, world!" -- -- Minimal definition: 'toMessage' (and usually 'toContentType'). class ToMessage a where
src/Happstack/Server/SURI.hs view
@@ -37,8 +37,9 @@ a_path :: String -> SURI -> SURI a_path a (SURI u) = SURI $ u {URI.uriPath=a} -escape, unEscape :: String -> String-unEscape = URI.unEscapeString . map (\x->if x=='+' then ' ' else x)+escape, unEscape, unEscapeQS :: String -> String+unEscapeQS = URI.unEscapeString . map (\x->if x=='+' then ' ' else x)+unEscape = URI.unEscapeString escape = URI.escapeURIString URI.isAllowedInURI -- | Returns true if the URI is absolute
src/Happstack/Server/SimpleHTTP.hs view
@@ -41,7 +41,6 @@ , simpleHTTP'' , simpleHTTPWithSocket , simpleHTTPWithSocket'- , httpsOnSocket , bindPort , bindIPv4 , parseConfig@@ -88,7 +87,6 @@ import qualified Data.Version as DV import Happstack.Server.Internal.Monads (FilterFun, WebT(..), unFilterFun, runServerPartT, ununWebT) import qualified Happstack.Server.Internal.Listen as Listen (listen, listen',listenOn, listenOnIPv4) -- So that we can disambiguate 'Writer.listen'-import Happstack.Server.Internal.TLS (httpsOnSocket) import Network (Socket) import qualified Paths_happstack_server as Cabal import System.Console.GetOpt ( OptDescr(Option)@@ -164,14 +162,14 @@ -- port) for 'bindPort' and 'simpleHTTPWithSocket'. -- -- see also: 'bindPort', 'bindIPv4'-simpleHTTPWithSocket :: (ToMessage a) => Socket -> Maybe HTTPS -> Conf -> ServerPartT IO a -> IO ()+simpleHTTPWithSocket :: (ToMessage a) => Socket -> Conf -> ServerPartT IO a -> IO () simpleHTTPWithSocket = simpleHTTPWithSocket' id -- | Like 'simpleHTTP'' with a socket. simpleHTTPWithSocket' :: (ToMessage b, Monad m, Functor m) => (UnWebT m a -> UnWebT IO b)- -> Socket -> Maybe HTTPS -> Conf -> ServerPartT m a -> IO ()-simpleHTTPWithSocket' toIO socket mHttps conf hs =- Listen.listen' socket mHttps conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req))+ -> Socket -> Conf -> ServerPartT m a -> IO ()+simpleHTTPWithSocket' toIO socket conf hs =+ Listen.listen' socket conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req)) -- | Bind port and return the socket for use with 'simpleHTTPWithSocket'. This -- function always binds to IPv4 ports until Network module is fixed
src/Happstack/Server/Types.hs view
@@ -7,7 +7,7 @@ setHeader, setHeaderBS, setHeaderUnsafe, addHeader, addHeaderBS, addHeaderUnsafe, setRsCode, -- setCookie, setCookies,- Conf(..), nullConf, TLSConf(..), HTTPS(..), result, resultBS,+ LogAccess, logMAccess, Conf(..), nullConf, result, resultBS, redirect, -- redirect_, redirect', redirect'_, isHTTP1_0, isHTTP1_1, RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength,
tests/Happstack/Server/Tests.hs view
@@ -29,7 +29,7 @@ allTests = "happstack-server tests" ~: [ cookieParserTest , acceptEncodingParserTest- , splitMultipart + , multipart , compressFilterResponseTest ] @@ -74,27 +74,37 @@ , (" x-gzip",[("x-gzip", Nothing)]) ] -splitMultipart :: Test-splitMultipart =- "split multipart" ~: assertFailure "update splitMultipart test"-{-- [ Just [pack "1"] @=? - splitParts (pack "boundary")- (pack "beg\r\n--boundary\r\n1\r\n--boundary--\r\nend")- , Just [pack "1\n"] @=? - splitParts (pack "boundary")- (pack "beg\r\n--boundary\r\n1\n\r\n--boundary--\r\nend")- , Just [pack "1\r\n"] @=? - splitParts (pack "boundary")- (pack "beg\r\n--boundary\r\n1\r\n\r\n--boundary--\r\nend")- , Just [pack "1\n\r"] @=? - splitParts (pack "boundary")- (pack "beg\r\n--boundary\r\n1\n\r\r\n--boundary--\r\nend")- , Just [pack "\r\n1\n\r"] @=? - splitParts (pack "boundary")- (pack "beg\r\n--boundary\r\n\r\n1\n\r\r\n--boundary--\r\nend")+multipart :: Test+multipart =+ "split multipart" ~:+ [ ([BodyPart (pack "content-type: text/plain\r\n") (pack "1")], Nothing) @=?+ parseMultipartBody (pack "boundary")+ (pack "--boundary\r\ncontent-type: text/plain\r\n\r\n1\r\n--boundary--\r\nend")++ , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1")], Nothing) @=?+ parseMultipartBody (pack "boundary.with.dot")+ (pack "--boundary.with.dot\r\ncontent-type: text/plain\r\n\r\n1\r\n--boundary.with.dot--\r\nend")++ , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1")], Nothing) @=?+ parseMultipartBody (pack "boundary")+ (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\r\n--boundary--\r\nend")++ , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1\n")], Nothing) @=?+ parseMultipartBody (pack "boundary")+ (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\n\r\n--boundary--\r\nend")++ , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1\r\n")], Nothing) @=?+ parseMultipartBody (pack "boundary")+ (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\r\n\r\n--boundary--\r\nend")+ , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1\n\r")], Nothing) @=?+ parseMultipartBody (pack "boundary")+ (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\n\r\r\n--boundary--\r\nend")++ , ([BodyPart (pack "content-type: text/plain\r\n") (pack "\r\n1\n\r")], Nothing) @=?+ parseMultipartBody (pack "boundary")+ (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n\r\n1\n\r\r\n--boundary--\r\nend") ]--}+ compressFilterResponseTest :: Test compressFilterResponseTest = "compressFilterResponseTest" ~: @@ -122,6 +132,7 @@ , rqHeaders = headers , rqBody = b , rqPeer = ("",0)+ , rqSecure = False } compressPart :: ServerPart Response