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: 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 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 diff --git a/src/Happstack/Server/Internal/Cookie.hs b/src/Happstack/Server/Internal/Cookie.hs --- a/src/Happstack/Server/Internal/Cookie.hs +++ b/src/Happstack/Server/Internal/Cookie.hs @@ -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 diff --git a/src/Happstack/Server/Internal/Handler.hs b/src/Happstack/Server/Internal/Handler.hs --- a/src/Happstack/Server/Internal/Handler.hs +++ b/src/Happstack/Server/Internal/Handler.hs @@ -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 () 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 @@ -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 diff --git a/src/Happstack/Server/Internal/MessageWrap.hs b/src/Happstack/Server/Internal/MessageWrap.hs --- a/src/Happstack/Server/Internal/MessageWrap.hs +++ b/src/Happstack/Server/Internal/MessageWrap.hs @@ -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' 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 @@ -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) diff --git a/src/Happstack/Server/Internal/RFC822Headers.hs b/src/Happstack/Server/Internal/RFC822Headers.hs --- a/src/Happstack/Server/Internal/RFC822Headers.hs +++ b/src/Happstack/Server/Internal/RFC822Headers.hs @@ -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) diff --git a/src/Happstack/Server/Internal/TLS.hs b/src/Happstack/Server/Internal/TLS.hs deleted file mode 100644 --- a/src/Happstack/Server/Internal/TLS.hs +++ /dev/null @@ -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 diff --git a/src/Happstack/Server/Internal/TimeoutSocketTLS.hs b/src/Happstack/Server/Internal/TimeoutSocketTLS.hs deleted file mode 100644 --- a/src/Happstack/Server/Internal/TimeoutSocketTLS.hs +++ /dev/null @@ -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) 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 @@ -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 diff --git a/src/Happstack/Server/Response.hs b/src/Happstack/Server/Response.hs --- a/src/Happstack/Server/Response.hs +++ b/src/Happstack/Server/Response.hs @@ -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 diff --git a/src/Happstack/Server/SURI.hs b/src/Happstack/Server/SURI.hs --- a/src/Happstack/Server/SURI.hs +++ b/src/Happstack/Server/SURI.hs @@ -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 diff --git a/src/Happstack/Server/SimpleHTTP.hs b/src/Happstack/Server/SimpleHTTP.hs --- a/src/Happstack/Server/SimpleHTTP.hs +++ b/src/Happstack/Server/SimpleHTTP.hs @@ -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 diff --git a/src/Happstack/Server/Types.hs b/src/Happstack/Server/Types.hs --- a/src/Happstack/Server/Types.hs +++ b/src/Happstack/Server/Types.hs @@ -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, diff --git a/tests/Happstack/Server/Tests.hs b/tests/Happstack/Server/Tests.hs --- a/tests/Happstack/Server/Tests.hs +++ b/tests/Happstack/Server/Tests.hs @@ -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