happstack-server 6.4.6 → 6.5.1
raw patch · 27 files changed
+682/−544 lines, 27 filesdep +HsOpenSSLdep −happstack-datadep ~directorydep ~mtldep ~network
Dependencies added: HsOpenSSL
Dependencies removed: happstack-data
Dependency ranges changed: directory, mtl, network
Files
- happstack-server.cabal +18/−7
- src/Happstack/Server/Auth.hs +1/−3
- src/Happstack/Server/Cookie.hs +1/−4
- src/Happstack/Server/FileServe/BuildingBlocks.hs +35/−62
- src/Happstack/Server/HTTPClient/HTTP.hs +2/−2
- src/Happstack/Server/HTTPClient/Stream.hs +10/−10
- src/Happstack/Server/Internal/Compression.hs +2/−1
- src/Happstack/Server/Internal/Cookie.hs +0/−1
- src/Happstack/Server/Internal/Handler.hs +36/−39
- src/Happstack/Server/Internal/Listen.hs +64/−7
- src/Happstack/Server/Internal/MessageWrap.hs +7/−9
- src/Happstack/Server/Internal/Monads.hs +82/−10
- src/Happstack/Server/Internal/Multipart.hs +20/−20
- src/Happstack/Server/Internal/Socket.hs +10/−8
- src/Happstack/Server/Internal/TLS.hs +67/−0
- src/Happstack/Server/Internal/TimeoutIO.hs +22/−0
- src/Happstack/Server/Internal/TimeoutSocket.hs +25/−11
- src/Happstack/Server/Internal/TimeoutSocketTLS.hs +60/−0
- src/Happstack/Server/Internal/Types.hs +105/−88
- src/Happstack/Server/Monads.hs +12/−3
- src/Happstack/Server/Response.hs +1/−1
- src/Happstack/Server/Routing.hs +36/−6
- src/Happstack/Server/RqData.hs +55/−28
- src/Happstack/Server/SURI.hs +1/−1
- src/Happstack/Server/SimpleHTTP.hs +9/−8
- src/Happstack/Server/Types.hs +1/−1
- src/Happstack/Server/XSLT.hs +0/−214
happstack-server.cabal view
@@ -1,5 +1,5 @@ Name: happstack-server-Version: 6.4.6+Version: 6.5.1 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,6 +27,11 @@ Description: Build the testsuite, and include the tests in the library Default: False +Flag disable-https+ Description: Compile server with out https:// support+ Default: False+ Manual: True+ Library Exposed-modules:@@ -44,6 +49,8 @@ Happstack.Server.Internal.LowLevel Happstack.Server.Internal.MessageWrap -- Happstack.Server.Internal.NoPush+ Happstack.Server.Internal.TLS+ Happstack.Server.Internal.TimeoutIO Happstack.Server.Internal.TimeoutManager Happstack.Server.Internal.TimeoutSocket Happstack.Server.Internal.Monads@@ -56,8 +63,6 @@ Happstack.Server.SimpleHTTP Happstack.Server.Types Happstack.Server.Validation- Happstack.Server.XSLT- if flag(tests) Exposed-modules: Happstack.Server.Tests@@ -86,10 +91,9 @@ extensible-exceptions, filepath, hslogger >= 1.0.2,- happstack-data >= 6.0 && < 6.1, html, monad-control >= 0.3 && < 0.4,- mtl >= 1.1 && < 2.1,+ mtl >= 2 && < 2.1, old-locale, old-time, parsec < 4,@@ -103,12 +107,19 @@ utf8-string >= 0.3.4 && < 0.4, xhtml, zlib+ if !flag(disable-https)+ Exposed-modules:+ Happstack.Server.Internal.TimeoutSocketTLS+ Build-Depends:+ HsOpenSSL == 0.10.*+ Extra-Libraries: crypto++ ssl+ else+ CPP-Options: -DDISABLE_HTTPS+ if flag(network_2_2_3) Build-Depends: network >= 2.2.3 else Build-Depends: network < 2.2.3, network-bytestring-- hs-source-dirs: src if flag(tests)
src/Happstack/Server/Auth.hs view
@@ -5,10 +5,8 @@ import Control.Monad (MonadPlus(mzero, mplus)) import Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as B-import Data.Char (chr) import qualified Data.Map as M-import Happstack.Server.Monads (Happstack, FilterMonad, ServerMonad, WebMonad, escape, getHeaderM, setHeaderM)-import Happstack.Server.Types (Response)+import Happstack.Server.Monads (Happstack, escape, getHeaderM, setHeaderM) import Happstack.Server.Response (unauthorized, toResponse) -- | A simple HTTP basic authentication guard.
src/Happstack/Server/Cookie.hs view
@@ -11,9 +11,6 @@ where import Control.Monad.Trans (MonadIO(..))-import Data.Data (Data)-import Data.Typeable (Typeable)-import Data.Time.Clock (UTCTime) import Happstack.Server.Internal.Monads (FilterMonad, composeFilter) import Happstack.Server.Internal.Cookie (Cookie(..), CookieLife(..), calcLife, mkCookie, mkCookieHeader) import Happstack.Server.Types (Response, addHeader)@@ -47,4 +44,4 @@ -- > ok $ "The cookie has been expired." expireCookie :: (MonadIO m, FilterMonad Response m) => String -> m () -expireCookie cookieName = addCookie Expired (mkCookie cookieName "")+expireCookie name = addCookie Expired (mkCookie name "")
src/Happstack/Server/FileServe/BuildingBlocks.hs view
@@ -51,46 +51,30 @@ isDot ) where -import Control.Exception.Extensible (IOException, SomeException, Exception(fromException), bracket, handleJust)-import Control.Monad (MonadPlus(mzero), msum)-import Control.Monad.Trans (MonadIO(liftIO))+import Control.Exception.Extensible (IOException, bracket, catch)+import Control.Monad (MonadPlus(mzero), msum)+import Control.Monad.Trans (MonadIO(liftIO)) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S-import Data.Data (Data, Typeable)-import Data.Maybe (fromMaybe, maybe)-import Data.Map (Map)-import qualified Data.Map as Map-import Happstack.Server.Monads (Happstack, ServerMonad(askRq), FilterMonad, WebMonad, require)-import Happstack.Server.Response (ToMessage(toResponse), ifModifiedSince, forbidden, ok, seeOther)-import Happstack.Server.Types (Length(ContentLength), Request(rqPaths, rqUri), Response(SendFile), RsFlags(rsfLength), nullRsFlags, result, resultBS, setHeader)-import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, getModificationTime)-import System.FilePath ((</>), addTrailingPathSeparator, hasDrive, isPathSeparator, joinPath, splitDirectories, takeExtension, isValid)-import System.IO (IOMode(ReadMode), hFileSize, hClose, openBinaryFile, withBinaryFile)-import System.Locale (defaultTimeLocale, rfc822DateFormat)-import System.Log.Logger (Priority(DEBUG), logM)-import System.Time (CalendarTime, formatCalendarTime, toCalendarTime, toUTCTime)-+import Data.Data (Data, Typeable)+import Data.List (sort)+import Data.Maybe (fromMaybe)+import Data.Map (Map)+import qualified Data.Map as Map+import Happstack.Server.Monads (ServerMonad(askRq), FilterMonad, WebMonad)+import Happstack.Server.Response (ToMessage(toResponse), ifModifiedSince, forbidden, ok, seeOther)+import Happstack.Server.Types (Length(ContentLength), Request(rqPaths, rqUri), Response(SendFile), RsFlags(rsfLength), nullRsFlags, result, resultBS, setHeader)+import Prelude hiding (catch)+import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, getModificationTime)+import System.FilePath ((</>), addTrailingPathSeparator, hasDrive, isPathSeparator, joinPath, takeExtension, isValid)+import System.IO (IOMode(ReadMode), hFileSize, hClose, openBinaryFile, withBinaryFile)+import System.Locale (defaultTimeLocale)+import System.Log.Logger (Priority(DEBUG), logM)+import System.Time (CalendarTime, formatCalendarTime, toCalendarTime, toUTCTime) import Text.Blaze ((!)) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A --- FIXME: why are these functions here ?--ioErrors :: SomeException -> Maybe IOException-ioErrors = fromException--errorwrapper :: (MonadIO m, MonadPlus m, FilterMonad Response m) => String -> String -> m Response-errorwrapper binarylocation loglocation- = require getErrorLog $ \errorLog ->- return $ toResponse errorLog- where getErrorLog- = handleJust ioErrors (const (return Nothing)) $- do bintime <- getModificationTime binarylocation- logtime <- getModificationTime loglocation- if (logtime > bintime)- then fmap Just $ readFile loglocation- else return Nothing- -- * Mime-Type / Content-Type -- |a 'Map' from file extensions to content-types@@ -498,9 +482,9 @@ -> [String] -> FilePath -> m Response-browseIndex renderFn serveFn mimeFn ixFiles localPath =+browseIndex renderFn _serveFn _mimeFn _ixFiles localPath = do c <- liftIO $ getDirectoryContents localPath- listing <- renderFn localPath $ filter (/= ".") c+ listing <- renderFn localPath $ filter (/= ".") (sort c) ok $ toResponse $ listing data EntryKind = File | Directory | UnknownKind deriving (Eq, Ord, Read, Show, Data, Typeable, Enum)@@ -516,9 +500,9 @@ do fps' <- liftIO $ mapM (getMetaData localPath) fps return $ H.html $ do H.head $ do- H.title $ H.string "Directory Listing"- H.meta ! A.httpEquiv (H.stringValue "Content-Type") ! A.content (H.stringValue "text/html;charset=utf-8")- H.style $ H.string $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"+ H.title $ H.toHtml "Directory Listing"+ H.meta ! A.httpEquiv (H.toValue "Content-Type") ! A.content (H.toValue "text/html;charset=utf-8")+ H.style $ H.toHtml $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }" , "table, th, td { border: 1px solid #353948; }" , "td.size { text-align: right; font-size: 0.7em; width: 50px }" , "td.date { text-align: right; font-size: 0.7em; width: 130px }"@@ -532,19 +516,8 @@ , "img { width: 20px }" , "a { text-decoration: none }" ]-{-- H.style $ H.string $ unlines [ "table { border-collapse: collapse; font-family: 'sans-serif'; }"- , "table, th, td { border: 1px solid #98BF21; }" - , "td.size { text-align: right; }"- , "td.date { text-align: right; }"- , "td { padding-right: 1em; padding-left: 1em; }"- , "tr { background-color: white; }"- , "tr.alt { background-color: #EAF2D3 }"- , "th { background-color: #A7C942; color: white; font-size: 1.125em; }"- ]--} H.body $ do- H.h1 $ H.string "Directory Listing"+ H.h1 $ H.toHtml "Directory Listing" renderDirectoryContentsTable fps' -- | a function to generate an HTML table showing the contents of a directory on the disk@@ -558,23 +531,23 @@ renderDirectoryContentsTable :: [(FilePath, Maybe CalendarTime, Maybe Integer, EntryKind)] -- ^ list of files+meta data, see 'getMetaData' -> H.Html renderDirectoryContentsTable fps =- H.table $ do H.thead $ do H.th $ H.string ""- H.th $ H.string "Name"- H.th $ H.string "Last modified"- H.th $ H.string "Size"+ H.table $ do H.thead $ do H.th $ H.toHtml ""+ H.th $ H.toHtml "Name"+ H.th $ H.toHtml "Last modified"+ H.th $ H.toHtml "Size" H.tbody $ mapM_ mkRow (zip fps $ cycle [False, True]) where mkRow :: ((FilePath, Maybe CalendarTime, Maybe Integer, EntryKind), Bool) -> H.Html mkRow ((fp, modTime, count, kind), alt) = - (if alt then (! A.class_ (H.stringValue "alt")) else id) $+ (if alt then (! A.class_ (H.toValue "alt")) else id) $ H.tr $ do H.td (mkKind kind)- H.td (H.a ! A.href (H.stringValue fp) $ H.string fp)- H.td ! A.class_ (H.stringValue "date") $ (H.string $ maybe "-" (formatCalendarTime defaultTimeLocale "%d-%b-%Y %X %Z") modTime)- (maybe id (\c -> (! A.title (H.stringValue (show c)))) count) (H.td ! A.class_ (H.stringValue "size") $ (H.string $ maybe "-" prettyShow count)) + H.td (H.a ! A.href (H.toValue fp) $ H.toHtml fp)+ H.td ! A.class_ (H.toValue "date") $ (H.toHtml $ maybe "-" (formatCalendarTime defaultTimeLocale "%d-%b-%Y %X %Z") modTime)+ (maybe id (\c -> (! A.title (H.toValue (show c)))) count) (H.td ! A.class_ (H.toValue "size") $ (H.toHtml $ maybe "-" prettyShow count)) mkKind :: EntryKind -> H.Html mkKind File = return ()- mkKind Directory = H.string "➦"+ mkKind Directory = H.toHtml "➦" mkKind UnknownKind = return () prettyShow x | x > 1024 = prettyShowK $ x `div` 1024@@ -598,12 +571,12 @@ getMetaData localPath fp = do let localFp = localPath </> fp modTime <- (fmap Just . toCalendarTime =<< getModificationTime localFp) `catch` - (const $ return Nothing)+ (\(_ :: IOException) -> return Nothing) count <- do de <- doesDirectoryExist localFp if de then do return Nothing else do bracket (openBinaryFile localFp ReadMode) hClose (fmap Just . hFileSize) - `catch` (\(e :: IOException) -> return Nothing)+ `catch` (\(_e :: IOException) -> return Nothing) kind <- do fe <- doesFileExist localFp if fe then return File
src/Happstack/Server/HTTPClient/HTTP.hs view
@@ -141,7 +141,7 @@ -- Util import Data.Bits ((.&.)) import Data.Char-import Data.List (partition,elemIndex,intersperse)+import Data.List (foldl', elemIndex, intersperse, partition) import Control.Monad (when,forM) import Numeric (readHex) import Text.ParserCombinators.ReadP@@ -1011,7 +1011,7 @@ urlEncodeVars :: [(String,String)] -> String urlEncodeVars ((n,v):t) = let (same,diff) = partition ((==n) . fst) t- in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same)+ in urlEncode n ++ '=' : foldl' (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same) ++ urlEncodeRest diff where urlEncodeRest [] = [] urlEncodeRest diff = '&' : urlEncodeVars diff
src/Happstack/Server/HTTPClient/Stream.hs view
@@ -30,14 +30,12 @@ ) where +import Control.Monad (liftM) import Control.Exception.Extensible as Exception-import System.IO.Error---- Networking-import Network.Socket--import Control.Monad (liftM)-import System.IO+import Network.Socket (ShutdownCmd(..), Socket, SocketOption(SoError), getSocketOption, recv, send, sClose, shutdown)+import Prelude hiding (catch)+import System.IO (Handle, IOMode(..), hClose, hFlush, hPutStrLn, openFile)+import System.IO.Error (isEOFError) data ConnError = ErrorReset | ErrorClosed@@ -126,13 +124,15 @@ myrecv :: Socket -> Int -> IO String myrecv sock len =- let handler e = if isEOFError e then return [] else ioError e- in System.IO.Error.catch (recv sock len) handler+ recv sock len `catch` + (\e ->+ if isEOFError e + then return []+ else ioError e) -- | Allows stream logging. -- Refer to 'debugStream' below. data Debug x = Dbg Handle x- instance (Stream x) => Stream (Debug x) where readBlock (Dbg h c) n =
src/Happstack/Server/Internal/Compression.hs view
@@ -36,7 +36,7 @@ installHandler accept = do let eEncoding = bestEncoding allEncodings $ BS.unpack accept- (coding,identityAllowed,action) <- case eEncoding of+ (coding, identityAllowed, action) <- case eEncoding of Left _ -> do setResponseCode 406 finishWith $ toResponse ""@@ -46,6 +46,7 @@ , fromMaybe (fail badEncoding) (lookup a allEncodingHandlers) )+ Right [] -> fail badEncoding action coding identityAllowed return coding
src/Happstack/Server/Internal/Cookie.hs view
@@ -16,7 +16,6 @@ ) where -import Control.Applicative ((<$>)) import qualified Data.ByteString.Char8 as C import Data.Char (chr, toLower) import Data.Data (Data, Typeable)
src/Happstack/Server/Internal/Handler.hs view
@@ -28,33 +28,30 @@ import Happstack.Server.Internal.Multipart import Happstack.Server.Internal.RFC822Headers import Happstack.Server.Internal.MessageWrap--- import Happstack.Server.Internal.NoPush import Happstack.Server.SURI(SURI(..),path,query) import Happstack.Server.SURI.ParseURI+import Happstack.Server.Internal.TimeoutIO (TimeoutIO(..)) import qualified Happstack.Server.Internal.TimeoutManager as TM-import Happstack.Server.Internal.TimeoutSocket (sGetContents, sPutTickle, sendFileTickle)-import Network.Socket (Socket)-import Network.Socket.ByteString (sendAll) import Numeric import System.Directory (removeFile) import System.IO import System.IO.Error (isDoesNotExistError) -request :: TM.Handle -> Conf -> Socket -> Host -> (Request -> IO Response) -> IO ()-request thandle conf sock host handler = rloop thandle conf sock host handler =<< sGetContents thandle sock+request :: TimeoutIO -> Conf -> Host -> (Request -> IO Response) -> IO ()+request timeoutIO conf host handler =+ rloop timeoutIO conf host handler =<< toGetContents timeoutIO required :: String -> Maybe a -> Either String a required err Nothing = Left err required _ (Just a) = Right a -rloop :: TM.Handle+rloop :: TimeoutIO -> Conf- -> Socket -> Host -> (Request -> IO Response) -> L.ByteString -> IO ()-rloop thandle conf sock host handler inputStr+rloop timeoutIO conf host handler inputStr | L.null inputStr = return () | otherwise = join $@@ -65,22 +62,22 @@ let (m,u,v) = requestLine rql headers' <- parseHeaders "host" (L.unpack headerStr) let headers = mkHeaders headers'- let contentLength = fromMaybe 0 $ fmap fst (P.readInt =<< getHeaderUnsafe contentlengthC headers)+ let contentLen = fromMaybe 0 $ fmap fst (P.readInt =<< getHeaderUnsafe contentlengthC headers) (body, nextRequest) <- case () of- () | contentLength < 0 -> fail "negative content-length"+ () | contentLen < 0 -> fail "negative content-length" | isJust $ getHeaderBS transferEncodingC headers -> return $ consumeChunks restStr- | otherwise -> return (L.splitAt (fromIntegral contentLength) restStr)+ | otherwise -> return (L.splitAt (fromIntegral contentLen) restStr) let cookies = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" headers)), c <- cl ] -- Ugle- return (m, u, cookies, v, headers, body, host, nextRequest)+ return (m, u, cookies, v, headers, body, nextRequest) case parseRequest of Left err -> error $ "failed to parse HTTP request: " ++ err- Right (m, u, cookies, v, headers, body, host, nextRequest)+ Right (m, u, cookies, v, headers, body, nextRequest) -> return $ do bodyRef <- newMVar (Body body) bodyInputRef <- newEmptyMVar- let req = Request m (pathEls (path u)) (path u) (query u)+ let req = Request (toSecure timeoutIO) m (pathEls (path u)) (path u) (query u) (queryInput u) bodyInputRef cookies v headers bodyRef host let ioseq act = act >>= \x -> x `seq` return x@@ -101,10 +98,10 @@ logger host' user time requestLn responseCode size referer userAgent -- withNoPush sock $ putAugmentedResult thandle sock req res- putAugmentedResult thandle sock req res+ putAugmentedResult timeoutIO req res -- clean up tmp files cleanupTempFiles req- when (continueHTTP req res) $ rloop thandle conf sock host handler nextRequest+ when (continueHTTP req res) $ rloop timeoutIO conf host handler nextRequest -- NOTE: if someone took the inputs and never put them back, then they are responsible for the cleanup cleanupTempFiles :: Request -> IO ()@@ -207,22 +204,22 @@ staticHeaders :: Headers staticHeaders = foldr (uncurry setHeaderBS) (mkHeaders [])- [ (serverC, happsC) ]+ [ (serverC, happstackC) ] -- FIXME: we should not be controlling the response headers in mysterious ways in this low level code -- headers should be set by application code and the core http engine should be very lean.-putAugmentedResult :: TM.Handle -> Socket -> Request -> Response -> IO ()-putAugmentedResult thandle outp req res = do+putAugmentedResult :: TimeoutIO -> Request -> Response -> IO ()+putAugmentedResult timeoutIO req res = do case res of -- standard bytestring response Response {} -> do- let chunked = rsfLength (rsFlags res) == TransferEncodingChunked && isHTTP1_1 req- sendTop (if chunked then Nothing else (Just (fromIntegral (L.length (rsBody res))))) chunked+ let isChunked = rsfLength (rsFlags res) == TransferEncodingChunked && isHTTP1_1 req+ sendTop (if isChunked then Nothing else (Just (fromIntegral (L.length (rsBody res))))) isChunked when (rqMethod req /= HEAD)- (let body = if chunked+ (let body = if isChunked then chunk (rsBody res) else rsBody res- in sPutTickle thandle outp body)+ in toPutLazy timeoutIO body) -- zero-copy sendfile response -- the handle *should* be closed by the garbage collector @@ -231,25 +228,25 @@ off = sfOffset res count = sfCount res sendTop (Just count) False- TM.tickle thandle- sendFileTickle thandle outp infp off count+ TM.tickle (toHandle timeoutIO)+ toSendFile timeoutIO infp off count where ph (HeaderPair k vs) = map (\v -> P.concat [k, fsepC, v, crlfC]) vs- sendTop cl chunked = do- allHeaders <- augmentHeaders req res cl chunked- sendAll outp $ B.concat $ concat+ sendTop cl isChunked = do+ allHeaders <- augmentHeaders req res cl isChunked+ toPut timeoutIO $ B.concat $ concat [ (pversion $ rqVersion req) -- Print HTTP version , [responseMessage $ rsCode res] -- Print responseCode , concatMap ph (M.elems allHeaders) -- Print all headers , [crlfC] ]- TM.tickle thandle+ TM.tickle (toHandle timeoutIO) chunk :: L.ByteString -> L.ByteString chunk Empty = LC.pack "0\r\n\r\n" chunk (Chunk c cs) = Chunk (B.pack $ showHex (B.length c) "\r\n") (Chunk c (Chunk (B.pack "\r\n") (chunk cs))) augmentHeaders :: Request -> Response -> Maybe Integer -> Bool -> IO Headers-augmentHeaders req res mcl chunked = do+augmentHeaders req res mcl isChunked = do -- TODO: Hoist static headers to the toplevel. raw <- getApproximateTime let stdHeaders = staticHeaders `M.union`@@ -264,7 +261,7 @@ | otherwise -> [] TransferEncodingChunked -- we check 'chunked' because we might not use this mode if the client is http 1.0- | chunked -> [(transferEncodingC, HeaderPair transferEncodingC [chunkedC])]+ | isChunked -> [(transferEncodingC, HeaderPair transferEncodingC [chunkedC])] | otherwise -> [] )@@ -307,7 +304,7 @@ http11 :: B.ByteString http11 = P.pack "HTTP/1.1" --- Constants+-- * ByteString Constants connectionC :: B.ByteString connectionC = P.pack "Connection"@@ -321,8 +318,8 @@ crlfC = P.pack "\r\n" fsepC :: B.ByteString fsepC = P.pack ": "-contentTypeC :: B.ByteString-contentTypeC = P.pack "Content-Type"+-- contentTypeC :: B.ByteString+-- contentTypeC = P.pack "Content-Type" contentLengthC :: B.ByteString contentLengthC = P.pack "Content-Length" contentlengthC :: B.ByteString@@ -333,10 +330,10 @@ dateCLower = P.map toLower dateC serverC :: B.ByteString serverC = P.pack "Server"-happsC :: B.ByteString-happsC = P.pack $ "Happstack/" ++ DV.showVersion Paths.version-textHtmlC :: B.ByteString-textHtmlC = P.pack "text/html; charset=utf-8"+happstackC :: B.ByteString+happstackC = P.pack $ "Happstack/" ++ DV.showVersion Paths.version+-- textHtmlC :: B.ByteString+-- textHtmlC = P.pack "text/html; charset=utf-8" transferEncodingC :: B.ByteString transferEncodingC = P.pack "Transfer-Encoding" chunkedC :: B.ByteString
src/Happstack/Server/Internal/Listen.hs view
@@ -4,10 +4,19 @@ 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, @@ -16,6 +25,10 @@ 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@@ -70,11 +83,22 @@ let port' = port conf socketm <- listenOn port' setSocketOption socketm KeepAlive 1- listen' socketm conf hand+ 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 -- | Use a previously bind port and listen-listen' :: Socket -> Conf -> (Request -> IO Response) -> IO ()-listen' s conf hand = do+listen' :: Socket -> Maybe HTTPS -> Conf -> (Request -> IO Response) -> IO ()+listen' s mhttps conf hand = do {- #ifndef mingw32_HOST_OS -}@@ -83,21 +107,54 @@ #endif -} let port' = port conf- log' NOTICE ("Listening on port " ++ show port') 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) work (sock, hn, p) = do tid <- myThreadId thandle <- register tm (killThread tid)- request thandle conf sock (hn,fromIntegral p) hand `E.catch` eh+ let timeoutIO = TS.timeoutSocketIO thandle sock+ request timeoutIO conf (hn,fromIntegral p) hand `E.catch` eh -- remove thread from timeout table cancel thandle sClose sock loop = forever $ do w <- acceptLite s forkIO $ work w- pe e = log' ERROR ("ERROR in accept thread: " ++ show e)+ pe e = log' ERROR ("ERROR in http accept thread: " ++ show e) infi = loop `catchSome` pe >> infi- infi `finally` (sClose s) -- >> killThread ttid)++ infi `finally` (sClose s >> killThread httpsTid)+ {-- #ifndef mingw32_HOST_OS -}
src/Happstack/Server/Internal/MessageWrap.hs view
@@ -9,7 +9,6 @@ import Control.Monad.Trans (MonadIO(liftIO)) import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.Lazy.Char8 as L-import Data.Maybe import Data.Int (Int64) import Happstack.Server.Internal.Types as H import Happstack.Server.Internal.Multipart@@ -52,24 +51,23 @@ isDecodable :: Maybe ContentType -> Bool isDecodable Nothing = True -- assume it is application/x-www-form-urlencoded isDecodable (Just (ContentType "application" "x-www-form-urlencoded" _)) = True- isDecodable (Just (ContentType "multipart" "form-data" ps)) = True+ isDecodable (Just (ContentType "multipart" "form-data" _ps)) = True isDecodable (Just _) = False bodyInput bodyPolicy req = liftIO $- do let getBS (Body bs) = bs- ctype = parseContentType . P.unpack =<< getHeader "content-type" req+ do let ctype = parseContentType . P.unpack =<< getHeader "content-type" req mbi <- tryTakeMVar (rqInputsBody req) case mbi of (Just bi) -> do putMVar (rqInputsBody req) bi return (bi, Nothing) Nothing ->- do rqBody <- takeRequestBody req- case rqBody of+ do rqbody <- takeRequestBody req+ case rqbody of Nothing -> return ([], Just $ "bodyInput: Request body was already consumed.") (Just (Body bs)) -> - do r@(inputs, err) <- decodeBody bodyPolicy ctype bs+ do r@(inputs, _err) <- decodeBody bodyPolicy ctype bs putMVar (rqInputsBody req) inputs return r @@ -107,9 +105,9 @@ -> [(String,String)] -- ^ Content-type parameters -> L.ByteString -- ^ Request body -> IO ([(String,Input)], Maybe String) -- ^ Input variables and values.-multipartDecode inputWorker ps inp =+multipartDecode worker ps inp = case lookup "boundary" ps of- Just b -> multipartBody inputWorker (L.pack b) inp+ Just b -> multipartBody worker (L.pack b) inp Nothing -> return ([], Just $ "boundary not found in parameters: " ++ show ps) -- | Get the path components from a String.
src/Happstack/Server/Internal/Monads.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeFamilies, UndecidableInstances #-} {-| This module defines the Monad stack used by Happstack. You mostly don't want to be looking in here. Look in "Happstack.Server.Monads" instead. -} module Happstack.Server.Internal.Monads where@@ -8,6 +8,17 @@ import Control.Monad ( MonadPlus(mzero, mplus), ap, liftM, msum ) import Control.Monad.Base ( MonadBase, liftBase )+import Control.Monad.Error ( ErrorT(ErrorT), runErrorT+ , Error, MonadError, throwError+ , catchError, mapErrorT+ )+import Control.Monad.Reader ( ReaderT(ReaderT), runReaderT+ , MonadReader, ask, local, mapReaderT+ )+import Control.Monad.RWS ( RWST, mapRWST+ )++import Control.Monad.State (MonadState, StateT, get, put, mapStateT) import Control.Monad.Trans ( MonadTrans, lift , MonadIO, liftIO )@@ -15,19 +26,12 @@ , MonadBaseControl(..) , ComposeSt, defaultLiftBaseWith, defaultRestoreM )-import Control.Monad.Reader ( ReaderT(ReaderT), runReaderT- , MonadReader, ask, local- ) import Control.Monad.Writer ( WriterT(WriterT), runWriterT , MonadWriter, tell, pass- , listens+ , listens, mapWriterT ) import qualified Control.Monad.Writer as Writer (listen) -- So that we can disambiguate 'Listen.listen'-import Control.Monad.State (MonadState, get, put)-import Control.Monad.Error ( ErrorT(ErrorT), runErrorT- , Error, MonadError, throwError- , catchError, mapErrorT- )+ import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT) import qualified Data.ByteString.Lazy.UTF8 as LU (fromString) import Data.Char (ord)@@ -554,3 +558,71 @@ encodeEntity c | ord c > 127 = "&#" ++ show (ord c) ++ ";" | otherwise = [c]++------------------------------------------------------------------------------+-- ServerMonad, FilterMonad, and WebMonad instances for ReaderT, StateT, +-- WriterT, and RWST+------------------------------------------------------------------------------++-- ReaderT++instance (ServerMonad m) => ServerMonad (ReaderT r m) where+ askRq = lift askRq+ localRq f = mapReaderT (localRq f)++instance (FilterMonad res m) => FilterMonad res (ReaderT r m) where+ setFilter f = lift $ setFilter f+ composeFilter = lift . composeFilter+ getFilter = mapReaderT getFilter++instance (WebMonad a m) => WebMonad a (ReaderT r m) where+ finishWith = lift . finishWith++-- StateT++instance (ServerMonad m) => ServerMonad (StateT s m) where+ askRq = lift askRq+ localRq f = mapStateT (localRq f)++instance (FilterMonad res m) => FilterMonad res (StateT s m) where+ setFilter f = lift $ setFilter f+ composeFilter = lift . composeFilter+ getFilter m = mapStateT (\m' -> + do ((b,s), f) <- getFilter m'+ return ((b, f), s)) m++instance (WebMonad a m) => WebMonad a (StateT s m) where+ finishWith = lift . finishWith+++-- WriterT++instance (ServerMonad m, Monoid w) => ServerMonad (WriterT w m) where+ askRq = lift askRq+ localRq f = mapWriterT (localRq f)++instance (FilterMonad res m, Monoid w) => FilterMonad res (WriterT w m) where+ setFilter f = lift $ setFilter f+ composeFilter = lift . composeFilter+ getFilter m = mapWriterT (\m' -> + do ((b,w), f) <- getFilter m'+ return ((b, f), w)) m++instance (WebMonad a m, Monoid w) => WebMonad a (WriterT w m) where+ finishWith = lift . finishWith++-- RWST++instance (ServerMonad m, Monoid w) => ServerMonad (RWST r w s m) where+ askRq = lift askRq+ localRq f = mapRWST (localRq f)++instance (FilterMonad res m, Monoid w) => FilterMonad res (RWST r w s m) where+ setFilter f = lift $ setFilter f+ composeFilter = lift . composeFilter+ getFilter m = mapRWST (\m' -> + do ((b,s,w), f) <- getFilter m'+ return ((b, f), s, w)) m++instance (WebMonad a m, Monoid w) => WebMonad a (RWST r w s m) where+ finishWith = lift . finishWith
src/Happstack/Server/Internal/Multipart.hs view
@@ -1,27 +1,25 @@ module Happstack.Server.Internal.Multipart where -import Control.Monad (MonadPlus(mplus), foldM)-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Internal as B-import Data.ByteString.Lazy.Internal (ByteString(Chunk, Empty))-import Data.ByteString.Lazy.Internal as L-import qualified Data.ByteString.Lazy.UTF8 as LU-import qualified Data.ByteString.Char8 as S-import Data.List (intercalate)-import Data.Maybe (fromMaybe)-import Data.Int (Int64)-import Text.ParserCombinators.Parsec (ParseError, parse)+import Control.Monad (MonadPlus(mplus))+import qualified Data.ByteString.Lazy.Char8 as L+import Data.ByteString.Lazy.Internal (ByteString(Chunk, Empty))+import qualified Data.ByteString.Lazy.UTF8 as LU+import qualified Data.ByteString.Char8 as S+import Data.Maybe (fromMaybe)+import Data.Int (Int64)+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)+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. -- -- TODO: this function has not been profiled. spanS :: (L.ByteString -> Bool) -> L.ByteString -> (L.ByteString, L.ByteString) spanS f cs0 = spanS' 0 cs0- where spanS' n Empty = (Empty, Empty)+ where spanS' _ Empty = (Empty, Empty) spanS' n bs@(Chunk c cs) | n >= S.length c = let (x, y) = spanS' 0 cs@@ -32,7 +30,7 @@ takeWhileS :: (L.ByteString -> Bool) -> L.ByteString -> L.ByteString takeWhileS f cs0 = takeWhile' 0 cs0- where takeWhile' n Empty = Empty+ where takeWhile' _ Empty = Empty takeWhile' n bs@(Chunk c cs) | n >= S.length c = Chunk c (takeWhile' 0 cs) | not (f (Chunk (S.drop n c) cs)) = (Chunk (S.take n c) Empty)@@ -74,6 +72,7 @@ -> L.ByteString -- ^ content to save -> IO (Bool, Int64 , FilePath) -- ^ truncated?, saved bytes, saved filename +defaultFileSaver :: FilePath -> Int64 -> FilePath -> ByteString -> IO (Bool, Int64, FilePath) defaultFileSaver tmpDir diskQuota filename b = do (fn, h) <- openBinaryTempFile tmpDir filename (trunc, len) <- hPutLimit diskQuota h b@@ -123,8 +122,8 @@ {-# INLINE hPutLimit #-} hPutLimit' :: Int64 -> Handle -> Int64 -> L.ByteString -> IO (Bool, Int64)-hPutLimit' _maxCount h count Empty = return (False, count)-hPutLimit' maxCount h count (Chunk c cs)+hPutLimit' _maxCount _h count Empty = return (False, count)+hPutLimit' maxCount h count (Chunk c cs) | (count + fromIntegral (S.length c)) > maxCount = do S.hPut h (S.take (fromIntegral (maxCount - count)) c) return (True, maxCount)@@ -146,6 +145,7 @@ cont (BodyWork ctype ps b) cd -> return $ Failed Nothing ("Expected content-disposition: form-data but got " ++ show cd)+ (BodyResult {}) -> return $ Failed Nothing "bodyPartToInput: Got unexpected BodyResult." bodyPartsToInputs :: InputWorker -> [BodyPart] -> IO ([(String,Input)], Maybe String) bodyPartsToInputs _ [] = @@ -184,8 +184,8 @@ parseMultipartBody :: L.ByteString -> L.ByteString -> ([BodyPart], Maybe String) parseMultipartBody boundary s = case dropPreamble boundary s of- (partData, Just e) -> ([], Just e)- (partData, Nothing) -> splitParts boundary partData+ (_partData, Just e) -> ([], Just e)+ (partData, Nothing) -> splitParts boundary partData dropPreamble :: L.ByteString -> L.ByteString -> (L.ByteString, Maybe String) dropPreamble b s | isBoundary b s = (dropLine s, Nothing)
src/Happstack/Server/Internal/Socket.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE TemplateHaskell #-}-module Happstack.Server.Internal.Socket(acceptLite) where+module Happstack.Server.Internal.Socket+ ( acceptLite+ , sockAddrToHostName+ ) where import Data.List (intersperse) import Data.Word (Word32)@@ -15,10 +18,8 @@ , SockAddr(..) , HostName , accept- , socketToHandle ) import Numeric (showHex)-import System.IO type HostAddress = Word32 type HostAddress6 = (Word32, Word32, Word32, Word32)@@ -50,8 +51,12 @@ acceptLite sock = do (sock', addr) <- S.accept sock (N.PortNumber p) <- N.socketPort sock'- - let peer = $(if supportsIPv6+ let peer = sockAddrToHostName addr+ return (sock', peer, p)++sockAddrToHostName :: S.SockAddr -> S.HostName+sockAddrToHostName addr =+ $(if supportsIPv6 then return $ CaseE (VarE (mkName "addr")) [Match @@ -73,6 +78,3 @@ (S.SockAddrInet _ ha) -> showHostAddress ha _ -> error "Unsupported socket" |])- - return (sock', peer, p)-
+ src/Happstack/Server/Internal/TLS.hs view
@@ -0,0 +1,67 @@+{-# 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/TimeoutIO.hs view
@@ -0,0 +1,22 @@+module Happstack.Server.Internal.TimeoutIO + ( TimeoutIO(..)+ ) where++import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import Happstack.Server.Internal.TimeoutManager (Handle)+import Network.Socket.SendFile (ByteCount, Offset)+++-- |TimeoutIO is a record which abstracts out all the network IO+-- functions needed by the request handling loop. This allows use to+-- use the same event loop for handle both http:// and https://.+data TimeoutIO = TimeoutIO+ { toHandle :: Handle+ , toPutLazy :: L.ByteString -> IO ()+ , toPut :: B.ByteString -> IO ()+ , toGetContents :: IO L.ByteString+ , toSendFile :: FilePath -> Offset -> ByteCount -> IO ()+ , toShutdown :: IO ()+ , toSecure :: Bool+ }
src/Happstack/Server/Internal/TimeoutSocket.hs view
@@ -4,31 +4,34 @@ -} module Happstack.Server.Internal.TimeoutSocket where -import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay, threadWaitWrite)-import Control.Exception (SomeException, catch, throw)+import Control.Concurrent (threadWaitWrite)+import Control.Exception (catch, throw) import Control.Monad (liftM, when) 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 Network.Socket.ByteString as N-import Data.Word-import Data.IORef-import Data.List (foldl')-import Data.Time.Clock.POSIX(POSIXTime, getPOSIXTime)-import Happstack.Server.Internal.Clock (getApproximatePOSIXTime)+import Network.Socket (sClose)+import qualified Network.Socket.ByteString as N import qualified Happstack.Server.Internal.TimeoutManager as TM+import Happstack.Server.Internal.TimeoutIO (TimeoutIO(..)) import Network.Socket (Socket, ShutdownCmd(..), shutdown) import Network.Socket.SendFile (Iter(..), ByteCount, Offset, sendFileIterWith') import Network.Socket.ByteString (sendAll) import Prelude hiding (catch)-import System.IO (Handle, hClose, hIsEOF, hWaitForInput) import System.IO.Error (isDoesNotExistError) import System.IO.Unsafe (unsafeInterleaveIO) -sPutTickle :: TM.Handle -> Socket -> L.ByteString -> IO ()-sPutTickle thandle sock cs =+sPutLazyTickle :: TM.Handle -> Socket -> L.ByteString -> IO ()+sPutLazyTickle thandle sock cs = do L.foldrChunks (\c rest -> sendAll sock c >> TM.tickle thandle >> rest) (return ()) cs+{-# INLINE sPutLazyTickle #-}++sPutTickle :: TM.Handle -> Socket -> B.ByteString -> IO ()+sPutTickle thandle sock cs =+ do sendAll sock cs+ TM.tickle thandle+ return () {-# INLINE sPutTickle #-} sGetContents :: TM.Handle @@ -64,3 +67,14 @@ iterTickle' cont (Sent _ cont) -> do iterTickle' cont++timeoutSocketIO :: TM.Handle -> Socket -> TimeoutIO+timeoutSocketIO handle socket =+ TimeoutIO { toHandle = handle+ , toShutdown = sClose socket + , toPutLazy = sPutLazyTickle handle socket+ , toPut = sPutTickle handle socket+ , toGetContents = sGetContents handle socket+ , toSendFile = sendFileTickle handle socket+ , toSecure = False+ }
+ src/Happstack/Server/Internal/TimeoutSocketTLS.hs view
@@ -0,0 +1,60 @@+{-# 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
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, RankNTypes #-} module Happstack.Server.Internal.Types (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..),@@ -9,7 +9,7 @@ setHeader, setHeaderBS, setHeaderUnsafe, addHeader, addHeaderBS, addHeaderUnsafe, setRsCode, -- setCookie, setCookies,- Conf(..), nullConf, result, resultBS,+ Conf(..), nullConf, TLSConf(..), HTTPS(..), result, resultBS, redirect, -- redirect_, redirect', redirect'_, isHTTP1_0, isHTTP1_1, RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength,@@ -24,14 +24,13 @@ import Control.Concurrent.MVar import qualified Data.Map as M import Data.Data (Data)-import Data.IORef (IORef, atomicModifyIORef, readIORef) import Data.Time.Format (FormatTime(..)) import Data.Typeable(Typeable) import qualified Data.ByteString.Char8 as P import Data.ByteString.Char8 (ByteString,pack) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.UTF8 as LU (fromString)-import Data.Int (Int, Int8, Int16, Int32, Int64)+import Data.Int (Int8, Int16, Int32, Int64) import Data.Maybe import Data.List import Data.Word (Word, Word8, Word16, Word32, Word64)@@ -40,6 +39,7 @@ 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 ()@@ -53,37 +53,57 @@ -- | 'True' if 'Request' is HTTP version @1.1@ isHTTP1_1 :: Request -> Bool-isHTTP1_1 rq = case rqVersion rq of HttpVersion 1 1 -> True; _ -> False+isHTTP1_1 rq =+ case rqVersion rq of+ HttpVersion 1 1 -> True+ _ -> False -- | 'True' if 'Request' is HTTP version @1.0@ isHTTP1_0 :: Request -> Bool-isHTTP1_0 rq = case rqVersion rq of HttpVersion 1 0 -> True; _ -> False+isHTTP1_0 rq =+ case rqVersion rq of+ HttpVersion 1 0 -> True+ _ -> False -- | Should the connection be used for further messages after this. -- | isHTTP1_0 && hasKeepAlive || isHTTP1_1 && hasNotConnectionClose continueHTTP :: Request -> Response -> Bool---continueHTTP rq res = isHTTP1_1 rq && getHeader' connectionC rq /= Just closeC && rsfContentLength (rsFlags res)-continueHTTP rq res = (isHTTP1_0 rq && checkHeaderBS connectionC keepaliveC rq && rsfLength (rsFlags res) == ContentLength) ||- (isHTTP1_1 rq && not (checkHeaderBS connectionC closeC rq) && rsfLength (rsFlags res) /= NoContentLength)+continueHTTP rq res =+ (isHTTP1_0 rq && checkHeaderBS connectionC keepaliveC rq && rsfLength (rsFlags res) == ContentLength) ||+ (isHTTP1_1 rq && not (checkHeaderBS connectionC closeC rq) && rsfLength (rsFlags res) /= NoContentLength) -- | 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 (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- } +data Conf = Conf+ { port :: Int -- ^ Port for the server to listen on.+ , tls :: Maybe TLSConf+ , 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+ } -- | 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- }+nullConf =+ Conf { port = 8000+ , tls = Nothing+ , validator = Nothing+ , logAccess = Just logMAccess+ , timeout = 30+ } -- | 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 host user time requestLine responseCode size referer userAgent = logM "Happstack.Server.AccessLog.Combined" INFO $ formatRequestCombined host user time requestLine responseCode size referer userAgent @@ -92,15 +112,14 @@ deriving(Show,Read,Eq,Ord,Typeable,Data) -- | an HTTP header-data HeaderPair - = HeaderPair { hName :: ByteString -- ^ header name- , hValue :: [ByteString] -- ^ header value (or values if multiple occurances of the header are present)- } - deriving (Read,Show)--- | Combined headers.+data HeaderPair = HeaderPair+ { hName :: ByteString -- ^ header name+ , hValue :: [ByteString] -- ^ header value (or values if multiple occurances of the header are present)+ }+ deriving (Read,Show) -- | a Map of HTTP headers--- +-- -- the Map key is the header converted to lowercase type Headers = M.Map ByteString HeaderPair -- ^ lowercased name -> (realname, value) @@ -109,14 +128,14 @@ -- encoding is used. -- -- see also: 'nullRsFlags', 'notContentLength', and 'chunked'-data Length +data Length = ContentLength -- ^ automatically add a @Content-Length@ header to the 'Response' | TransferEncodingChunked -- ^ do not add a @Content-Length@ header. Do use @chunked@ output encoding | NoContentLength -- ^ do not set @Content-Length@ or @chunked@ output encoding. deriving (Eq, Ord, Read, Show, Enum) -- | Result flags-data RsFlags = RsFlags +data RsFlags = RsFlags { rsfLength :: Length } deriving (Show,Read,Typeable) @@ -136,7 +155,6 @@ contentLength :: Response -> Response contentLength res = res { rsFlags = flags } where flags = (rsFlags res) { rsfLength = ContentLength } - -- | a value extract from the @QUERY_STRING@ or 'Request' body -- -- If the input value was a file, then it will be saved to a temporary file on disk and 'inputValue' will contain @Left pathToTempFile@.@@ -144,27 +162,28 @@ { inputValue :: Either FilePath L.ByteString , inputFilename :: Maybe FilePath , inputContentType :: ContentType- } deriving (Show,Read,Typeable)+ } deriving (Show, Read, Typeable) -- | hostname & port type Host = (String, Int) -- ^ (hostname, port) -- | an HTTP Response-data Response = Response { rsCode :: Int,- rsHeaders :: Headers,- rsFlags :: RsFlags,- rsBody :: L.ByteString,- rsValidator :: Maybe (Response -> IO Response)- }- | SendFile { rsCode :: Int,- rsHeaders :: Headers,- rsFlags :: RsFlags,- rsValidator :: Maybe (Response -> IO Response),- sfFilePath :: FilePath, -- ^ file handle to send from- sfOffset :: Integer, -- ^ offset to start at- sfCount :: Integer -- ^ number of bytes to send- }- deriving (Typeable)+data Response+ = Response { rsCode :: Int+ , rsHeaders :: Headers+ , rsFlags :: RsFlags+ , rsBody :: L.ByteString+ , rsValidator :: Maybe (Response -> IO Response)+ }+ | SendFile { rsCode :: Int+ , rsHeaders :: Headers+ , rsFlags :: RsFlags+ , rsValidator :: Maybe (Response -> IO Response)+ , sfFilePath :: FilePath -- ^ file handle to send from+ , sfOffset :: Integer -- ^ offset to start at+ , sfCount :: Integer -- ^ number of bytes to send+ }+ deriving (Typeable) instance Show Response where showsPrec _ res@Response{} =@@ -186,27 +205,30 @@ -- what should the status code be ? instance Error Response where- strMsg str = - setHeader "Content-Type" "text/plain; charset=UTF-8" $ + strMsg str =+ setHeader "Content-Type" "text/plain; charset=UTF-8" $ result 500 str -- | an HTTP request-data Request = Request { rqMethod :: Method,- rqPaths :: [String],- rqUri :: String,- rqQuery :: String,- rqInputsQuery :: [(String,Input)],- rqInputsBody :: MVar [(String,Input)],- rqCookies :: [(String,Cookie)],- rqVersion :: HttpVersion,- rqHeaders :: Headers,- rqBody :: MVar RqBody,- rqPeer :: Host- } deriving(Typeable)+data Request = Request+ { rqSecure :: Bool -- ^ request uses https://+ , rqMethod :: Method -- ^ request method+ , rqPaths :: [String] -- ^ the uri, split on /, and then decoded+ , rqUri :: String -- ^ the raw rqUri+ , rqQuery :: String -- ^ the QUERY_STRING+ , rqInputsQuery :: [(String,Input)] -- ^ the QUERY_STRING decoded as key/value pairs+ , rqInputsBody :: MVar [(String,Input)] -- ^ the request body decoded as key/value pairs (when appropriate)+ , rqCookies :: [(String,Cookie)] -- ^ cookies+ , rqVersion :: HttpVersion -- ^ HTTP version+ , rqHeaders :: Headers -- ^ the HTTP request headers+ , rqBody :: MVar RqBody -- ^ the raw, undecoded request body+ , rqPeer :: Host -- ^ (hostname, port) of the client making the request+ } deriving (Typeable) instance Show Request where showsPrec _ rq = showString "================== Request =================" .+ showString "\nrqSecure = " . shows (rqMethod rq) . showString "\nrqMethod = " . shows (rqMethod rq) . showString "\nrqPaths = " . shows (rqPaths rq) . showString "\nrqUri = " . showString (rqUri rq) .@@ -224,9 +246,7 @@ -- IMPORTANT: You can really only call this function once. Subsequent -- calls will return 'Nothing'. takeRequestBody :: (MonadIO m) => Request -> m (Maybe RqBody)-takeRequestBody rq = liftIO $ tryTakeMVar (rqBody rq) --- takeRequestBody rq = return (rqBody rq)-+takeRequestBody rq = liftIO $ tryTakeMVar (rqBody rq) -- | read the request body inputs --@@ -240,37 +260,34 @@ return (Just bi) Nothing -> return Nothing -{--takeRequestBody rq = - do body <- atomicModifyIORef (rqBody rq) (\bdy -> (Nothing, bdy))- newBD <- readIORef (rqBody rq)- print newBD- newBD `seq` return body--} -- | Converts a Request into a String representing the corresponding URL rqURL :: Request -> String rqURL rq = '/':intercalate "/" (rqPaths rq) ++ (rqQuery rq) -- | a class for working with types that contain HTTP headers-class HasHeaders a where +class HasHeaders a where updateHeaders :: (Headers->Headers) -> a -> a -- ^ modify the headers- headers :: a -> Headers -- ^ extract the headers+ headers :: a -> Headers -- ^ extract the headers -instance HasHeaders Response where updateHeaders f rs = rs{rsHeaders=f $ rsHeaders rs}- headers = rsHeaders-instance HasHeaders Request where updateHeaders f rq = rq{rqHeaders = f $ rqHeaders rq} - headers = rqHeaders+instance HasHeaders Response where+ updateHeaders f rs = rs {rsHeaders=f $ rsHeaders rs }+ headers = rsHeaders -instance HasHeaders Headers where updateHeaders f = f- headers = id+instance HasHeaders Request where+ updateHeaders f rq = rq {rqHeaders = f $ rqHeaders rq }+ headers = rqHeaders +instance HasHeaders Headers where+ updateHeaders f = f+ headers = id+ -- | The body of an HTTP 'Request' newtype RqBody = Body { unBody :: L.ByteString } deriving (Read,Show,Typeable) -- | Sets the Response status code to the provided Int and lifts the computation -- into a Monad. setRsCode :: (Monad m) => Int -> Response -> m Response-setRsCode code rs = return rs {rsCode = code}+setRsCode code rs = return rs { rsCode = code } -- | Takes a list of (key,val) pairs and converts it into Headers. The -- keys will be converted to lowercase@@ -342,7 +359,7 @@ -- | Sets the key to the HeaderPair. This is the only way to associate a key -- with multiple values via the setHeader* functions. Does not force the key--- to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. +-- to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. setHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r setHeaderUnsafe key val = updateHeaders (M.insert key val) @@ -351,7 +368,7 @@ -------------------------------------------------------------- -- | Add a key/value pair to the header. If the key already has a value--- associated with it, then the value will be appended. +-- associated with it, then the value will be appended. -- Forces the key to be lowercase. addHeader :: HasHeaders r => String -> String -> r -> r addHeader key val = addHeaderBS (pack key) (pack val)@@ -361,18 +378,18 @@ addHeaderBS key val = addHeaderUnsafe (P.map toLower key) (HeaderPair key [val]) -- | Add a key/value pair to the header using the underlying HeaderPair data--- type. Does not force the key to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. +-- type. Does not force the key to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. addHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r addHeaderUnsafe key val = updateHeaders (M.insertWith join key val) where join (HeaderPair k vs1) (HeaderPair _ vs2) = HeaderPair k (vs1++vs2) -- | Creates a Response with the given Int as the status code and the provided--- String as the body of the Response +-- String as the body of the Response result :: Int -> String -> Response result code = resultBS code . LU.fromString -- | Acts as 'result' but works with ByteStrings directly.--- +-- -- By default, Transfer-Encoding: chunked will be used resultBS :: Int -> L.ByteString -> Response resultBS code s = Response code M.empty nullRsFlags s Nothing@@ -404,21 +421,21 @@ case readDec s of [(n,[])] -> n _ -> error "readDec' failed."- + -- | Read in any monad. readM :: (Monad m, Read t) => String -> m t readM s = case reads s of [(v,"")] -> return v _ -> fail "readM: parse error"- + -- |convert a 'ReadS a' result to 'Maybe a' fromReadS :: [(a, String)] -> Maybe a fromReadS [(n,[])] = Just n fromReadS _ = Nothing- + -- | This class is used by 'path' to parse a path component into a -- value.--- +-- -- The instances for number types ('Int', 'Float', etc) use 'readM' to -- parse the path component. --@@ -448,7 +465,7 @@ instance FromReqURI Word64 where fromReqURI = fromReadS . readDec instance FromReqURI Float where fromReqURI = readM instance FromReqURI Double where fromReqURI = readM-instance FromReqURI Bool where +instance FromReqURI Bool where fromReqURI s = let s' = map toLower s in case s' of
src/Happstack/Server/Monads.hs view
@@ -14,7 +14,7 @@ ServerPartT , ServerPart -- * Happstack class- , Happstack(..)+ , Happstack -- * ServerMonad , ServerMonad(..) , mapServerPartT@@ -39,7 +39,12 @@ import Control.Applicative (Alternative, Applicative) import Control.Monad (MonadPlus(mzero)) import Control.Monad.Trans (MonadIO(..),MonadTrans(lift))+import Control.Monad.Reader (ReaderT)+import Control.Monad.Writer (WriterT)+import Control.Monad.State (StateT)+import Control.Monad.RWS (RWST) import qualified Data.ByteString.Char8 as B+import Data.Monoid (Monoid) import Happstack.Server.Internal.Monads import Happstack.Server.Types (Response, addHeader, getHeader, setHeader) import Happstack.Server.RqData (HasRqData)@@ -49,8 +54,12 @@ , MonadIO m, MonadPlus m, HasRqData m, Monad m, Functor m , Applicative m, Alternative m) => Happstack m --instance (Functor m, Monad m, MonadPlus m, MonadIO m) => Happstack (ServerPartT m)+instance (Functor m, Monad m, MonadPlus m+ , MonadIO m) => Happstack (ServerPartT m)+instance (Happstack m) => Happstack (StateT s m)+instance (Happstack m) => Happstack (ReaderT r m)+instance (Happstack m, Monoid w) => Happstack (WriterT w m)+instance (Happstack m, Monoid w) => Happstack (RWST r w s m) -- | Get a header out of the request. getHeaderM :: (ServerMonad m) => String -> m (Maybe B.ByteString)
src/Happstack/Server/Response.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances, ScopedTypeVariables #-} -- | Functions and classes related to generating a 'Response' and setting the response code. For detailed instruction see the Happstack Crash Course: <http://happstack.com/docs/crashcourse/HelloWorld.html#response_code> module Happstack.Server.Response ( -- * Converting values to a 'Response'
src/Happstack/Server/Routing.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE FlexibleInstances, PatternGuards, ScopedTypeVariables, TypeSynonymInstances #-} -- | Route an incoming 'Request' to a handler. For more in-depth documentation see this section of the Happstack Crash Course: <http://happstack.com/docs/crashcourse/RouteFilters.html> module Happstack.Server.Routing - ( -- * Route by request method- methodM+ ( -- * Route by scheme+ http+ , https+ -- * Route by request method+ , methodM , methodOnly , methodSP , method@@ -22,10 +25,9 @@ , guardRq ) where -import Control.Monad (MonadPlus(mzero,mplus), unless)+import Control.Monad (MonadPlus(mzero), unless) import qualified Data.ByteString.Char8 as B-import Happstack.Server.Monads (ServerPartT, ServerMonad(..))-import Happstack.Server.Internal.Monads (WebT, anyRequest)+import Happstack.Server.Monads (ServerMonad(..)) import Happstack.Server.Types (Request(..), Method(..), FromReqURI(..), getHeader, rqURL) import System.FilePath (makeRelative, splitDirectories) @@ -52,6 +54,31 @@ rq <- askRq unless (f rq) mzero ++-- | guard which checks that an insecure connection was made via http://+--+-- Example:+--+-- > handler :: ServerPart Response+-- > handler =+-- > do https+-- > ...+http :: (ServerMonad m, MonadPlus m) => m ()+http = guardRq (not . rqSecure)+++-- | guard which checks that a secure connection was made via https://+--+-- Example:+--+-- > handler :: ServerPart Response+-- > handler =+-- > do https+-- > ...+https :: (ServerMonad m, MonadPlus m) => m ()+https = guardRq rqSecure++ -- | Guard against the method only (as opposed to 'methodM'). -- -- Example:@@ -63,7 +90,6 @@ method :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m () method meth = guardRq $ \rq -> matchMethod meth (rqMethod rq) - -- | Guard against the method. This function also guards against -- *any remaining path segments*. See 'method' for the version -- that guards only by method.@@ -106,6 +132,10 @@ -- -- NOTE: This style of combinator is going to be deprecated in the -- future. It is better to just use 'method'.+--+-- > handler :: ServerPart Response+-- > handler = method [GET, HEAD] >> nullDir >> subHandler+{-# DEPRECATED methodSP "use method instead." #-} methodSP :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m b-> m b methodSP m handle = methodM m >> handle
src/Happstack/Server/RqData.hs view
@@ -30,6 +30,7 @@ -- body for matches keys. , body , queryString+ , bytestring -- * Validation and Parsing , checkRq , checkRqM @@ -57,10 +58,13 @@ import Control.Applicative (Applicative((<*>), pure), Alternative((<|>), empty), WrappedMonad(WrapMonad, unwrapMonad), (<$>)) import Control.Concurrent.MVar (newMVar)-import Control.Monad (MonadPlus(mzero), liftM)+import Control.Monad (MonadPlus(mzero)) import Control.Monad.Reader (ReaderT(ReaderT, runReaderT), MonadReader(ask, local), mapReaderT)+import Control.Monad.State (StateT, mapStateT)+import Control.Monad.Writer (WriterT, mapWriterT)+import Control.Monad.RWS (RWST, mapRWST) import Control.Monad.Error (Error(noMsg, strMsg))-import Control.Monad.Trans (MonadIO(..))+import Control.Monad.Trans (MonadIO(..), lift) import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.UTF8 as LU@@ -76,7 +80,7 @@ import Happstack.Server.Internal.RFC822Headers (parseContentType) import Happstack.Server.Types (ContentType(..), FromReqURI(..), Input(inputValue, inputFilename, inputContentType), Response, Request(rqInputsQuery, rqInputsBody, rqCookies, rqMethod), Method(POST,PUT), getHeader, readInputsBody) import Happstack.Server.Internal.MessageWrap (BodyPolicy(..), bodyInput, defaultBodyPolicy)-import Happstack.Server.Response (internalServerError, requestEntityTooLarge, toResponse)+import Happstack.Server.Response (requestEntityTooLarge, toResponse) newtype ReaderError r e a = ReaderError { unReaderError :: ReaderT r (Either e) a } deriving (Functor, Monad, MonadPlus)@@ -113,12 +117,14 @@ noMsg = Errors [] strMsg str = Errors [str] -mapReaderErrorT :: (Either e a -> Either e' b) -> (ReaderError r e a) -> (ReaderError r e' b)-mapReaderErrorT f m = ReaderError $ mapReaderT f (unReaderError m)-+{- commented out to avoid 'Defined but not used' warning. readerError :: (Monoid e, Error e) => e -> ReaderError r e b readerError e = mapReaderErrorT ((Left e) `apEither`) (return ()) +mapReaderErrorT :: (Either e a -> Either e' b) -> (ReaderError r e a) -> (ReaderError r e' b)+mapReaderErrorT f m = ReaderError $ mapReaderT f (unReaderError m)+-}+ runReaderError :: ReaderError r e a -> r -> Either e a runReaderError = runReaderT . unReaderError @@ -157,10 +163,10 @@ isDecodable :: Maybe ContentType -> Bool isDecodable Nothing = True -- assume it is application/x-www-form-urlencoded isDecodable (Just (ContentType "application" "x-www-form-urlencoded" _)) = True- isDecodable (Just (ContentType "multipart" "form-data" ps)) = True+ isDecodable (Just (ContentType "multipart" "form-data" _ps)) = True isDecodable (Just _) = False - rqDataError e = mzero+ rqDataError _e = mzero localRqEnv f m = do rq <- askRq b <- liftIO $ readInputsBody rq@@ -172,6 +178,30 @@ } localRq (const rq') m +------------------------------------------------------------------------------+-- HasRqData instances for ReaderT, StateT, WriterT, and RWST+------------------------------------------------------------------------------++instance (Monad m, HasRqData m) => HasRqData (ReaderT s m) where+ askRqEnv = lift askRqEnv+ localRqEnv f = mapReaderT (localRqEnv f)+ rqDataError e = lift (rqDataError e)++instance (Monad m, HasRqData m) => HasRqData (StateT s m) where+ askRqEnv = lift askRqEnv+ localRqEnv f = mapStateT (localRqEnv f)+ rqDataError e = lift (rqDataError e)++instance (Monad m, HasRqData m, Monoid w) => HasRqData (WriterT w m) where+ askRqEnv = lift askRqEnv+ localRqEnv f = mapWriterT (localRqEnv f)+ rqDataError e = lift (rqDataError e)++instance (Monad m, HasRqData m, Monoid w) => HasRqData (RWST r w s m) where+ askRqEnv = lift askRqEnv+ localRqEnv f = mapRWST (localRqEnv f)+ rqDataError e = lift (rqDataError e)+ -- | apply 'RqData a' to a 'RqEnv' -- -- see also: 'getData', 'getDataFn', 'withData', 'withDataFn', 'RqData', 'getDataFn'@@ -248,9 +278,9 @@ -- | like 'checkRq' but the check function can be monadic checkRqM :: (Monad m, HasRqData m) => m a -> (a -> m (Either String b)) -> m b checkRqM rq f =- do a <- rq- b <- f a- case b of+ do a <- rq+ eb <- f a+ case eb of (Left e) -> rqDataError (strMsg e) (Right b) -> return b @@ -286,7 +316,7 @@ fromMaybeBody funName fieldName mBody = case mBody of Nothing -> error $ funName ++ " " ++ fieldName ++ " failed because the request body has not been decoded yet. Try using 'decodeBody' to decode the body. Or the 'queryString' filter to ignore the body."- (Just body) -> body+ (Just bdy) -> bdy -- | Gets the first matching named input parameter -- @@ -296,8 +326,8 @@ lookInput :: (Monad m, HasRqData m) => String -> m Input lookInput name = do (query, mBody, _cookies) <- askRqEnv- let body = fromMaybeBody "lookInput" name mBody- case lookup name (query ++ body) of+ let bdy = fromMaybeBody "lookInput" name mBody+ case lookup name (query ++ bdy) of Just i -> return $ i Nothing -> rqDataError (strMsg $ "Parameter not found: " ++ name) @@ -309,8 +339,8 @@ lookInputs :: (Monad m, HasRqData m) => String -> m [Input] lookInputs name = do (query, mBody, _cookies) <- askRqEnv- let body = fromMaybeBody "lookInputs" name mBody- return $ lookups name (query ++ body)+ let bdy = fromMaybeBody "lookInputs" name mBody+ return $ lookups name (query ++ bdy) -- | Gets the first matching named input parameter as a lazy 'ByteString' --@@ -321,7 +351,7 @@ lookBS n = do i <- fmap inputValue (lookInput n) case i of- (Left fp) -> rqDataError $ (strMsg $ "lookBS: " ++ n ++ " is a file.")+ (Left _fp) -> rqDataError $ (strMsg $ "lookBS: " ++ n ++ " is a file.") (Right bs) -> return bs -- | Gets all matches for the named input parameter as lazy 'ByteString's@@ -334,7 +364,7 @@ do is <- fmap (map inputValue) (lookInputs n) case partitionEithers is of ([], bs) -> return bs- (fp, _) -> rqDataError (strMsg $ "lookBSs: " ++ n ++ " is a file.")+ (_fp, _) -> rqDataError (strMsg $ "lookBSs: " ++ n ++ " is a file.") -- | Gets the first matching named input parameter as a 'String' --@@ -458,8 +488,8 @@ lookPairs :: (Monad m, HasRqData m) => m [(String, Either FilePath String)] lookPairs = do (query, mBody, _cookies) <- askRqEnv- let body = fromMaybeBody "lookPairs" "" mBody- return $ map (\(n,vbs)->(n, (\e -> case e of Left fp -> Left fp ; Right bs -> Right (LU.toString bs)) $ inputValue vbs)) (query ++ body)+ let bdy = fromMaybeBody "lookPairs" "" mBody+ return $ map (\(n,vbs)->(n, (\e -> case e of Left fp -> Left fp ; Right bs -> Right (LU.toString bs)) $ inputValue vbs)) (query ++ bdy) -- | gets all the input parameters --@@ -470,8 +500,8 @@ lookPairsBS :: (Monad m, HasRqData m) => m [(String, Either FilePath L.ByteString)] lookPairsBS = do (query, mBody, _cookies) <- askRqEnv- let body = fromMaybeBody "lookPairsBS" "" mBody- return $ map (\(n,vbs) -> (n, inputValue vbs)) (query ++ body)+ let bdy = fromMaybeBody "lookPairsBS" "" mBody+ return $ map (\(n,vbs) -> (n, inputValue vbs)) (query ++ bdy) -- | The POST\/PUT body of a Request is not received or decoded unless -- this function is invoked. @@ -587,7 +617,7 @@ body :: (HasRqData m) => m a -> m a body rqData = localRqEnv f rqData where- f (_query, body, _cookies) = ([], body, [])+ f (_query, bdy, _cookies) = ([], bdy, []) -- | limit the scope to the QUERY_STRING --@@ -600,14 +630,11 @@ where f (query, _body, _cookies) = (query, Just [], []) -right :: (MonadPlus m) => Either a b -> m b-right (Right a) = return a-right (Left e) = mzero-+-- | limit the scope to 'Input's which produce a 'ByteString' (aka, not a file) bytestring :: (HasRqData m) => m a -> m a bytestring rqData = localRqEnv f rqData where- f (query, body, cookies) = (filter bsf query, filter bsf <$> body, cookies)+ f (query, bdy, cookies) = (filter bsf query, filter bsf <$> bdy, cookies) bsf (_, i) = case inputValue i of (Left _fp) -> False
src/Happstack/Server/SURI.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances #-} -- | A wrapper and type class so that functions like 'seeOther' can take a URI which is represented by a 'String', 'URI.URI', or other instance of 'ToSURI'. module Happstack.Server.SURI where
src/Happstack/Server/SimpleHTTP.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -41,6 +41,7 @@ , simpleHTTP'' , simpleHTTPWithSocket , simpleHTTPWithSocket'+ , httpsOnSocket , bindPort , bindIPv4 , parseConfig@@ -85,9 +86,9 @@ import Data.Maybe (fromMaybe) import qualified Data.Version as DV-import Happstack.Server.Internal.Monads (FilterFun, WebT(..), UnWebT, unFilterFun, mapServerPartT, runServerPartT, ununWebT)+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.Types (Conf(port, validator), Request, Response(rsBody, rsCode), nullConf, readDec', setHeader)+import Happstack.Server.Internal.TLS (httpsOnSocket) import Network (Socket) import qualified Paths_happstack_server as Cabal import System.Console.GetOpt ( OptDescr(Option)@@ -157,20 +158,20 @@ -- > -- do other stuff as root here -- > getUserEntryForName "www" >>= setUserID . userID -- > -- finally start handling incoming requests--- > tid <- forkIO $ simpleHTTPWithSocket socket conf impl+-- > tid <- forkIO $ simpleHTTPWithSocket socket Nothing conf impl -- -- Note: It's important to use the same conf (or at least the same -- port) for 'bindPort' and 'simpleHTTPWithSocket'. -- -- see also: 'bindPort', 'bindIPv4'-simpleHTTPWithSocket :: (ToMessage a) => Socket -> Conf -> ServerPartT IO a -> IO ()+simpleHTTPWithSocket :: (ToMessage a) => Socket -> Maybe HTTPS -> 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 -> 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))+ -> 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)) -- | 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, result, resultBS,+ Conf(..), nullConf, TLSConf(..), HTTPS(..), result, resultBS, redirect, -- redirect_, redirect', redirect'_, isHTTP1_0, isHTTP1_1, RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength,
− src/Happstack/Server/XSLT.hs
@@ -1,214 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances , UndecidableInstances,- DeriveDataTypeable, MultiParamTypeClasses, CPP, ScopedTypeVariables,- ScopedTypeVariables #-}--- | Functions to allow you to use XSLT to transform your output. To use this, you would generally design your happstack application to output XML. The xslt filter will then run an external tool which performs the tranforms. The transformed result will then be sent to the http client as the Response.------ NOTE: This module is currently looking for a maintainer. If you want to improve XSLT support in Happstack, please volunteer!-module Happstack.Server.XSLT- (xsltFile, xsltString, {- xsltElem, -} xsltFPS, xsltFPSIO, XSLPath,- xslt, doXslt, xsltproc,saxon,procFPSIO,procLBSIO,XSLTCommand,XSLTCmd- ) where---import System.Log.Logger--import Control.Concurrent (forkIO)-import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)-import Control.Monad-import Control.Monad.Trans-import qualified Data.ByteString.Char8 as B-import Happstack.Server.SimpleHTTP--import Happstack.Server.Types--- import Happstack.Server.MinHaXML-import Control.Exception.Extensible(bracket,try,SomeException)-import qualified Data.ByteString.Char8 as P-import qualified Data.ByteString.Lazy.Char8 as L-import System.Directory(removeFile)-import System.Environment(getEnv)-import System.Exit (ExitCode(..))-import System.IO-import System.IO.Unsafe(unsafePerformIO)-import System.Process (runInteractiveProcess, waitForProcess)--- import Text.XML.HaXml.Verbatim(verbatim)-import Happstack.Data hiding (Element)--logMX :: Priority -> String -> IO ()-logMX = logM "Happstack.Server.XSLT"--type XSLPath = FilePath--$(deriveAll [''Show,''Read,''Default, ''Eq, ''Ord]- [d|- data XSLTCmd = XSLTProc | Saxon - |]- )--xsltCmd :: XSLTCmd- -> XSLPath- -> FilePath- -> FilePath- -> (FilePath, [String])-xsltCmd XSLTProc = xsltproc'-xsltCmd Saxon = saxon'-{---- | Uses 'xsltString' to transform the given XML 'Element' into a--- a 'String'. -xsltElem :: XSLPath -> Element -> String-xsltElem xsl = xsltString xsl . verbatim--}--procLBSIO :: XSLTCmd -> XSLPath -> L.ByteString -> IO L.ByteString-procLBSIO xsltp' xsl inp = - withTempFile "happs-src.xml" $ \sfp sh -> do- withTempFile "happs-dst.xml" $ \dfp dh -> do- let xsltp = xsltCmd xsltp'- L.hPut sh inp- hClose sh- hClose dh- xsltFileEx xsltp xsl sfp dfp- s <- L.readFile dfp- logMX DEBUG (">>> XSLT: result: "++ show s)- return s---procFPSIO :: XSLTCommand- -> XSLPath- -> [P.ByteString]- -> IO [P.ByteString]-procFPSIO xsltp xsl inp = - withTempFile "happs-src.xml" $ \sfp sh -> do- withTempFile "happs-dst.xml" $ \dfp dh -> do- mapM_ (P.hPut sh) inp- hClose sh- hClose dh- xsltFileEx xsltp xsl sfp dfp- s <- P.readFile dfp- logMX DEBUG (">>> XSLT: result: "++ show s)- return [s]---- | Performs an XSL transformation with lists of ByteStrings instead of--- a String.-xsltFPS :: XSLPath -> [P.ByteString] -> [P.ByteString]-xsltFPS xsl = unsafePerformIO . xsltFPSIO xsl---- | Equivalent to 'xsltFPS' but does not hide the inherent IO of the low-level--- ByteString operations.-xsltFPSIO :: XSLPath -> [P.ByteString] -> IO [P.ByteString]-xsltFPSIO xsl inp = - withTempFile "happs-src.xml" $ \sfp sh -> do- withTempFile "happs-dst.xml" $ \dfp dh -> do- mapM_ (P.hPut sh) inp- hClose sh- hClose dh- xsltFile xsl sfp dfp- s <- P.readFile dfp- logMX DEBUG (">>> XSLT: result: "++ show s)- return [s]---- | Uses the provided xsl file to transform the given string.--- This function creates temporary files during its execution, but--- guarantees their cleanup.-xsltString :: XSLPath -> String -> String-xsltString xsl inp = unsafePerformIO $- withTempFile "happs-src.xml" $ \sfp sh -> do- withTempFile "happs-dst.xml" $ \dfp dh -> do- hPutStr sh inp- hClose sh- hClose dh- xsltFile xsl sfp dfp- s <- readFileStrict dfp- logMX DEBUG (">>> XSLT: result: "++ show s)- return s---- | Note that the xsl file must have .xsl suffix.-xsltFile :: XSLPath -> FilePath -> FilePath -> IO ()-xsltFile = xsltFileEx xsltproc'---- | Use @xsltproc@ to transform XML.-xsltproc :: XSLTCmd-xsltproc = XSLTProc-xsltproc' :: XSLTCommand-xsltproc' dst xsl src = ("xsltproc",["-o",dst,xsl,src])----- | Use @saxon@ to transform XML.-saxon :: XSLTCmd-saxon = Saxon-saxon' :: XSLTCommand-saxon' dst xsl src = ("java -classpath /usr/share/java/saxon.jar",- ["com.icl.saxon.StyleSheet"- ,"-o",dst,src,xsl])- -type XSLTCommand = XSLPath -> FilePath -> FilePath -> (FilePath,[String])-xsltFileEx :: XSLTCommand -> XSLPath -> FilePath -> FilePath -> IO ()-xsltFileEx xsltp xsl src dst = do- let msg = (">>> XSLT: Starting xsltproc " ++ unwords ["-o",dst,xsl,src])- logMX DEBUG msg- uncurry runCommand $ xsltp dst xsl src- logMX DEBUG (">>> XSLT: xsltproc done")---- Utilities--withTempFile :: String -> (FilePath -> Handle -> IO a) -> IO a-withTempFile str hand = bracket (openTempFile tempDir str) (removeFile . fst) (uncurry hand)--readFileStrict :: FilePath -> IO String-readFileStrict fp = do- let fseqM [] = return [] - fseqM xs = last xs `seq` return xs- fseqM =<< readFile fp--{-# NOINLINE tempDir #-}-tempDir :: FilePath-tempDir = unsafePerformIO $ tryAny [getEnv "TEMP",getEnv "TMP"] err- where err = return "/tmp"--tryAny :: [IO a] -> IO a -> IO a-tryAny [] c = c-tryAny (x:xs) c = either (\(_::SomeException) -> tryAny xs c) return =<< try x---- | Use @cmd@ to transform XML against @xslPath@. This function only--- acts if the content-type is @application\/xml@.-xslt :: (MonadIO m, MonadPlus m, ToMessage r) =>- XSLTCmd -- ^ XSLT preprocessor. Usually 'xsltproc' or 'saxon'.- -> XSLPath -- ^ Path to xslt stylesheet.- -> m r -- ^ Affected 'ServerPart's.- -> m Response-xslt cmd xslPath parts = do- res <- parts- if toContentType res == B.pack "application/xml"- then doXslt cmd xslPath (toResponse res)- else return (toResponse res)--doXslt :: (MonadIO m) =>- XSLTCmd -> XSLPath -> Response -> m Response-doXslt cmd xslPath res =- do new <- liftIO $ procLBSIO cmd xslPath $ rsBody res- return $ setHeader "Content-Type" "text/html" $- setHeader "Content-Length" (show $ L.length new) $- res { rsBody = new }- --- | Run an external command. Upon failure print status--- to stderr.-runCommand :: String -> [String] -> IO ()-runCommand cmd args = do - (_, outP, errP, pid) <- runInteractiveProcess cmd args Nothing Nothing- let pGetContents h = do mv <- newEmptyMVar- let put [] = putMVar mv []- put xs = last xs `seq` putMVar mv xs- forkIO (hGetContents h >>= put)- takeMVar mv- os <- pGetContents outP- es <- pGetContents errP- ec <- waitForProcess pid- case ec of- ExitSuccess -> return ()- ExitFailure e ->- do hPutStrLn stderr ("Running process "++unwords (cmd:args)++" FAILED ("++show e++")")- hPutStrLn stderr os- hPutStrLn stderr es- hPutStrLn stderr "Raising error..."- fail "Running external command failed"--