diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +# happstack-server [![Hackage Status](https://img.shields.io/hackage/v/happstack-server.svg)][hackage] + +[hackage]: https://hackage.haskell.org/package/happstack-server + +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. + +## Install + +There are packages available on [hackage][] and [stack](https://www.stackage.org/lts-3.12/package/happstack-server-7.4.5). + +## Documentation + +Please refer to the [Documentation on Hackage][hackage]. diff --git a/happstack-server.cabal b/happstack-server.cabal --- a/happstack-server.cabal +++ b/happstack-server.cabal @@ -1,5 +1,5 @@ Name: happstack-server -Version: 7.0.7 +Version: 7.9.3 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 @@ -9,29 +9,40 @@ homepage: http://happstack.com Category: Web, Happstack Build-Type: Simple -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.10 +Extra-Source-Files: tests/Happstack/Server/Tests.hs README.md -source-repository head - type: darcs - subdir: happstack-server - location: http://hub.darcs.net/stepcut/happstack +tested-with: + GHC == 9.14.1 + GHC == 9.12.2 + GHC == 9.10.2 + GHC == 9.8.2 + GHC == 9.6.7 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + GHC == 8.0.2 -Flag network_2_2_3 - Description: Choose newer network library with merged in network-bytestring. - Default: True +source-repository head + type: git + location: https://github.com/Happstack/happstack-server.git -Flag template_haskell - Description: Template Haskell is available on this system - Default: True - Manual: True +flag network-uri + description: Get Network.URI from the network-uri package + default: True Library + Default-language: Haskell2010 Exposed-modules: Happstack.Server Happstack.Server.Auth Happstack.Server.Cookie Happstack.Server.Compression - Happstack.Server.Client Happstack.Server.Error Happstack.Server.FileServe Happstack.Server.FileServe.BuildingBlocks @@ -45,13 +56,13 @@ Happstack.Server.Internal.LogFormat Happstack.Server.Internal.MessageWrap Happstack.Server.Internal.Multipart + Happstack.Server.Internal.RFC822Headers Happstack.Server.Internal.Socket Happstack.Server.Internal.TimeoutIO Happstack.Server.Internal.TimeoutManager Happstack.Server.Internal.TimeoutSocket Happstack.Server.Internal.Monads Happstack.Server.Monads - Happstack.Server.Proxy Happstack.Server.Response Happstack.Server.Routing Happstack.Server.RqData @@ -62,79 +73,75 @@ Other-modules: Happstack.Server.Internal.Clock Happstack.Server.Internal.LazyLiner - Happstack.Server.Internal.RFC822Headers - Happstack.Server.Internal.SocketTH Happstack.Server.SURI.ParseURI Paths_happstack_server - Build-Depends: base >= 4 && < 5, - base64-bytestring == 1.0.*, - blaze-html == 0.5.*, + if flag(network-uri) + build-depends: network >= 3.0.0 && < 3.3, + network-uri >= 2.6 && < 2.7 + else + build-depends: network < 2.6 + Build-Depends: base >= 4 && < 5, + base64-bytestring >= 1.0 && < 1.3, + blaze-html >= 0.5 && < 0.10, bytestring, containers, - directory, + directory >=1.2, + exceptions, extensible-exceptions, filepath, - hslogger >= 1.0.2, + hslogger >= 1.0.2, html, - monad-control >= 0.3 && < 0.4, - mtl >= 2 && < 2.2, - old-locale, - old-time, - parsec < 4, + monad-control >= 1.0 && < 1.1, + mtl >= 2.2 && < 2.4, + parsec < 4, process, - sendfile >= 0.7.1 && < 0.8, - system-filepath >= 0.3.1, + sendfile >= 0.7.1 && < 0.8, + system-filepath >= 0.3.1, syb, - text >= 0.10 && < 0.12, - time, - threads >= 0.5, - transformers >= 0.1.3 && < 0.4, - transformers-base >= 0.4 && < 0.5, - utf8-string >= 0.3.4 && < 0.4, - xhtml, + text >= 0.10 && < 2.2, + time >= 1.5, + threads >= 0.5, + transformers >= 0.1.3 && < 0.7, + transformers-base >= 0.4 && < 0.5, + utf8-string >= 0.3.4 && < 1.1, + xhtml < 3000.4, zlib - if flag(network_2_2_3) - Build-Depends: network >= 2.2.3 - else - Build-Depends: network < 2.2.3, network-bytestring - - if (flag(template_haskell) && !(arch(arm))) - Build-Depends: template-haskell - cpp-options: -DTEMPLATE_HASKELL - hs-source-dirs: src if !os(windows) Build-Depends: unix cpp-options: -DUNIX - Extensions: TemplateHaskell, DeriveDataTypeable, MultiParamTypeClasses, - TypeFamilies, FlexibleContexts, OverlappingInstances, - FlexibleInstances, UndecidableInstances, ScopedTypeVariables, - TypeSynonymInstances, PatternGuards + if impl(ghc < 8.6) + Default-Extensions: MonadFailDesugaring + + Other-Extensions: DeriveDataTypeable, MultiParamTypeClasses, + TypeFamilies, FlexibleContexts, + FlexibleInstances, UndecidableInstances, + ScopedTypeVariables, TypeSynonymInstances, PatternGuards CPP, ForeignFunctionInterface ghc-options: -Wall -fwarn-tabs - GHC-Prof-Options: -auto-all -- The policy is to support GHC versions no older than the GHC stable -- branch that was used by the latest Haskell Platform release -- available 18 months ago. In order to avoid people spending time -- keeping the build working for older versions, we tell Cabal that -- it shouldn't allow builds with them. - if impl(ghc < 7.0) + if impl(ghc < 8.0) buildable: False Test-Suite happstack-server-tests + Default-language: Haskell2010 Type: exitcode-stdio-1.0 Main-Is: Test.hs + Other-Modules: Happstack.Server.Tests GHC-Options: -threaded hs-source-dirs: tests Build-depends: HUnit, - base, + base >= 4 && < 5, bytestring, containers, happstack-server, parsec < 4, zlib - diff --git a/src/Happstack/Server.hs b/src/Happstack/Server.hs --- a/src/Happstack/Server.hs +++ b/src/Happstack/Server.hs @@ -10,7 +10,7 @@ Happstack.Server provides a self-contained HTTP server and a rich collection of types and functions for routing Requests, generating Responses, working with query parameters, form data, and cookies, serving files and more. A very simple, \"Hello World!\" web app looks like: - + > import Happstack.Server > main = simpleHTTP nullConf $ ok "Hello World!" @@ -33,12 +33,12 @@ the client. But, that would be a pretty barren wasteland to work in. The model for 'ServerPart' is essential the same, except we use the -much richer 'ServerPart' monad instead of the 'IO' monad. +much richer 'ServerPart' monad instead of the 'IO' monad. For in-depth documentation and runnable examples I highly recommend The Happstack Crash Course . -} -module Happstack.Server +module Happstack.Server ( -- * HTTP Server module Happstack.Server.SimpleHTTP -- * Request Routing @@ -59,19 +59,14 @@ , module Happstack.Server.I18N -- * Web-related Monads , module Happstack.Server.Monads - -- * Proxying - , module Happstack.Server.Proxy -- * Output Validation , module Happstack.Server.Validation -- * HTTP Types , module Happstack.Server.Types - -- * Other - , module Happstack.Server.Client -- , module Happstack.Server.Internal.Monads ) where -import Happstack.Server.Client import Happstack.Server.SimpleHTTP (simpleHTTP , simpleHTTP' , simpleHTTP'' @@ -90,7 +85,6 @@ import Happstack.Server.I18N import Happstack.Server.Response import Happstack.Server.Routing -import Happstack.Server.Proxy import Happstack.Server.RqData import Happstack.Server.Validation import Happstack.Server.Types diff --git a/src/Happstack/Server/Auth.hs b/src/Happstack/Server/Auth.hs --- a/src/Happstack/Server/Auth.hs +++ b/src/Happstack/Server/Auth.hs @@ -2,8 +2,12 @@ -- | Support for basic access authentication module Happstack.Server.Auth where +import Data.Foldable (foldl') +import Data.Bits (xor, (.|.)) +import Data.Maybe (fromMaybe) import Control.Monad (MonadPlus(mzero, mplus)) import Data.ByteString.Base64 as Base64 +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B import qualified Data.Map as M import Happstack.Server.Monads (Happstack, escape, getHeaderM, setHeaderM) @@ -25,26 +29,75 @@ -> M.Map String String -- ^ the username password map -> m a -- ^ the part to guard -> m a -basicAuth realmName authMap xs = basicAuthImpl `mplus` xs +basicAuth realmName authMap = basicAuthBy (validLoginPlaintext authMap) realmName + + +-- | Generalized version of 'basicAuth'. +-- +-- The function that checks the username password combination must be +-- supplied as first argument. +-- +-- example: +-- +-- > main = simpleHTTP nullConf $ +-- > msum [ basicAuth' (validLoginPlaintext (fromList [("happstack","rocks")])) "127.0.0.1" $ ok "You are in the secret club" +-- > , ok "You are not in the secret club." +-- > ] +-- +basicAuthBy :: (Happstack m) => + (B.ByteString -> B.ByteString -> Bool) -- ^ function that returns true if the name password combination is valid + -> String -- ^ the realm name + -> m a -- ^ the part to guard + -> m a +basicAuthBy validLogin realmName xs = basicAuthImpl `mplus` xs where basicAuthImpl = do aHeader <- getHeaderM "authorization" case aHeader of Nothing -> err - Just x -> - do r <- parseHeader x - case r of - (name, ':':password) | validLogin name password -> mzero - | otherwise -> err - _ -> err - validLogin name password = M.lookup name authMap == Just password - parseHeader h = + Just x -> + do (name, password) <- parseHeader x + if B.length password > 0 + && B.head password == ':' + && validLogin name (B.tail password) + then mzero + else err + parseHeader h = case Base64.decode . B.drop 6 $ h of (Left _) -> err - (Right bs) -> return (break (':'==) (B.unpack bs)) + (Right bs) -> return (B.break (':'==) bs) headerName = "WWW-Authenticate" headerValue = "Basic realm=\"" ++ realmName ++ "\"" err :: (Happstack m) => m a err = escape $ do setHeaderM headerName headerValue unauthorized $ toResponse "Not authorized" + + +-- | Function that looks up the plain text password for username in a +-- Map and returns True if it matches with the given password. +-- +-- Note: The implementation is hardened against timing attacks but not +-- completely safe. Ideally you should build your own predicate, using +-- a robust constant-time equality comparison from a cryptographic +-- library like sodium. +validLoginPlaintext :: + M.Map String String -- ^ the username password map + -> B.ByteString -- ^ the username + -> B.ByteString -- ^ the password + -> Bool +validLoginPlaintext authMap name password = fromMaybe False $ do + r <- M.lookup (B.unpack name) authMap + pure (constTimeEq (B.pack r) password) + where + -- (Mostly) constant time equality of bytestrings to prevent timing attacks by testing out passwords. This still + -- allows to extract the length of the configured password via timing attacks. This implementation is still brittle + -- in the sense that it relies on GHC not unrolling or vectorizing the loop. + {-# NOINLINE constTimeEq #-} + constTimeEq :: BS.ByteString -> BS.ByteString -> Bool + constTimeEq x y + | BS.length x /= BS.length y + = False + + | otherwise + = foldl' (.|.) 0 (BS.zipWith xor x y) == 0 diff --git a/src/Happstack/Server/Client.hs b/src/Happstack/Server/Client.hs deleted file mode 100644 --- a/src/Happstack/Server/Client.hs +++ /dev/null @@ -1,26 +0,0 @@ --- | a very simple interface for acting as an HTTP client. This is mostly used for things like "Happstack.Server.Proxy". You are more likely to want a library like http-enumerator . -module Happstack.Server.Client where - -import Happstack.Server.Internal.Handler (parseResponse, putRequest) -import Happstack.Server.Internal.Types (Response, Request, getHeader, readDec') -import Data.Maybe (fromJust) -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as L -import Network (PortID(PortNumber), connectTo, withSocketsDo) -import System.IO (BufferMode(NoBuffering), hFlush, hSetBuffering) - --- | Sends the serialized request to the host defined in the request --- and attempts to parse response upon arrival. -getResponse :: Request -> IO (Either String Response) -getResponse rq = withSocketsDo $ do - let (hostName,p) = span (/=':') $ fromJust $ fmap B.unpack $ getHeader "host" rq - portInt = if null p then 80 else readDec' $ tail p - portId = PortNumber $ toEnum $ portInt - h <- connectTo hostName portId - hSetBuffering h NoBuffering - - putRequest h rq - hFlush h - - inputStr <- L.hGetContents h - return $ parseResponse inputStr diff --git a/src/Happstack/Server/Compression.hs b/src/Happstack/Server/Compression.hs --- a/src/Happstack/Server/Compression.hs +++ b/src/Happstack/Server/Compression.hs @@ -2,6 +2,22 @@ -- | Filter for compressing the 'Response' body. module Happstack.Server.Compression ( compressedResponseFilter + , compressedResponseFilter' + , compressWithFilter + , gzipFilter + , deflateFilter + , identityFilter + , starFilter + , standardEncodingHandlers ) where -import Happstack.Server.Internal.Compression (compressedResponseFilter) +import Happstack.Server.Internal.Compression ( compressedResponseFilter + , compressedResponseFilter' + , compressWithFilter + , gzipFilter + , deflateFilter + , identityFilter + , starFilter + , standardEncodingHandlers + ) + diff --git a/src/Happstack/Server/Cookie.hs b/src/Happstack/Server/Cookie.hs --- a/src/Happstack/Server/Cookie.hs +++ b/src/Happstack/Server/Cookie.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} -- | Functions for creating, adding, and expiring cookies. To lookup cookie values see "Happstack.Server.RqData". module Happstack.Server.Cookie ( Cookie(..) , CookieLife(..) + , SameSite(..) , mkCookie , addCookie , addCookies @@ -12,13 +13,13 @@ import Control.Monad.Trans (MonadIO(..)) import Happstack.Server.Internal.Monads (FilterMonad, composeFilter) -import Happstack.Server.Internal.Cookie (Cookie(..), CookieLife(..), calcLife, mkCookie, mkCookieHeader) +import Happstack.Server.Internal.Cookie (Cookie(..), CookieLife(..), SameSite(..), calcLife, mkCookie, mkCookieHeader) import Happstack.Server.Types (Response, addHeader) -- | Add the 'Cookie' to 'Response'. -- -- example --- +-- -- > main = simpleHTTP nullConf $ -- > do addCookie Session (mkCookie "name" "value") -- > ok $ "You now have a session cookie." @@ -32,7 +33,7 @@ addHeaderM a v = composeFilter $ \res-> addHeader a v res -- | Add the list 'Cookie' to the 'Response'. --- +-- -- see also: 'addCookie' addCookies :: (MonadIO m, FilterMonad Response m) => [(CookieLife, Cookie)] -> m () addCookies = mapM_ (uncurry addCookie) @@ -43,5 +44,5 @@ -- > do expireCookie "name" -- > ok $ "The cookie has been expired." -expireCookie :: (MonadIO m, FilterMonad Response m) => String -> m () +expireCookie :: (MonadIO m, FilterMonad Response m) => String -> m () expireCookie name = addCookie Expired (mkCookie name "") diff --git a/src/Happstack/Server/Error.hs b/src/Happstack/Server/Error.hs --- a/src/Happstack/Server/Error.hs +++ b/src/Happstack/Server/Error.hs @@ -1,7 +1,7 @@ -- | Some useful functions if you want to wrap the 'ServerPartT' monad transformer around the 'ErrorT' monad transformer. e.g., @'ServerPartT' ('ErrorT' e m) a@. This allows you to use 'throwError' and 'catchError' inside your monad. module Happstack.Server.Error where -import Control.Monad.Error (Error, ErrorT(runErrorT)) +import Control.Monad.Trans.Except (ExceptT, runExceptT) import Happstack.Server.Monads (ServerPartT) import Happstack.Server.Internal.Monads (WebT, UnWebT, withRequest, mkWebT, runServerPartT, ununWebT) import Happstack.Server.Response (ok, toResponse) @@ -22,10 +22,10 @@ -- see also: 'simpleErrorHandler' spUnwrapErrorT:: Monad m => (e -> ServerPartT m a) -> Request - -> UnWebT (ErrorT e m) a + -> UnWebT (ExceptT e m) a -> UnWebT m a spUnwrapErrorT handler rq = \x -> do - err <- runErrorT x + err <- runExceptT x case err of Left e -> ununWebT $ runServerPartT (handler e) rq Right a -> return a @@ -48,9 +48,9 @@ -- function. -- -- DEPRECATED: use 'spUnwrapErrorT' instead. -errorHandlerSP :: (Monad m, Error e) => (Request -> e -> WebT m a) -> ServerPartT (ErrorT e m) a -> ServerPartT m a +errorHandlerSP :: (Monad m) => (Request -> e -> WebT m a) -> ServerPartT (ExceptT e m) a -> ServerPartT m a errorHandlerSP handler sps = withRequest $ \req -> mkWebT $ do - eer <- runErrorT $ ununWebT $ runServerPartT sps req + eer <- runExceptT $ ununWebT $ runServerPartT sps req case eer of Left err -> ununWebT (handler req err) Right res -> return res diff --git a/src/Happstack/Server/FileServe/BuildingBlocks.hs b/src/Happstack/Server/FileServe/BuildingBlocks.hs --- a/src/Happstack/Server/FileServe/BuildingBlocks.hs +++ b/src/Happstack/Server/FileServe/BuildingBlocks.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, ScopedTypeVariables, Rank2Types #-} +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, ScopedTypeVariables, Rank2Types #-} -- | Build your own file serving functions -- -- If the functions in "Happstack.Server.FileServe" do not quite do @@ -54,27 +54,26 @@ isDot ) where -import Control.Exception.Extensible (IOException, bracket, catch) +import Control.Exception.Extensible as E (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.Char (toLower) +import Data.Data (Data) import Data.List (sort) import Data.Maybe (fromMaybe) import Data.Map (Map) import qualified Data.Map as Map +import Data.Time (UTCTime, formatTime, defaultTimeLocale) import Filesystem.Path.CurrentOS (commonPrefix, encodeString, decodeString, collapse, append) 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.Html ((!)) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A @@ -98,7 +97,7 @@ guessContentType mimeMap filepath = case getExt filepath of "" -> Nothing - ext -> Map.lookup ext mimeMap + ext -> Map.lookup (map toLower ext) mimeMap -- FIXME? @foldCase@ would be more proper than @map toLower@ but would add a dependency. But are those edge cases ever going to be relevant here? -- | try to guess the content-type of a file based on its extension -- @@ -123,7 +122,7 @@ -- | a list of common index files. Specifically: @index.html@, @index.xml@, @index.gif@ -- --- Typically used as an argument to 'serveDiretory'. +-- Typically used as an argumebnt to 'serveDiretory'. defaultIxFiles :: [FilePath] defaultIxFiles= ["index.html","index.xml","index.gif"] @@ -132,6 +131,8 @@ fileNotFound fp = return $ result 404 $ "File not found " ++ fp -- | Similar to 'takeExtension' but does not include the extension separator char +-- +-- NOTE: this does not perform case folding. So @example.jpg@ will return @.jpg@ and @example.JPG@ will return @.JPG@. getExt :: FilePath -> String getExt fp = drop 1 $ takeExtension fp @@ -157,7 +158,7 @@ -- | Use sendFile to send the contents of a Handle sendFileResponse :: String -- ^ content-type string -> FilePath -- ^ file path for content to send - -> Maybe (CalendarTime, Request) -- ^ mod-time for the handle (MUST NOT be later than server's time of message origination), incoming request (used to check for if-modified-since header) + -> Maybe (UTCTime, Request) -- ^ mod-time for the handle (MUST NOT be later than server's time of message origination), incoming request (used to check for if-modified-since header) -> Integer -- ^ offset into Handle -> Integer -- ^ number of bytes to send -> Response @@ -173,7 +174,7 @@ -- lazyByteStringResponse :: String -- ^ content-type string (e.g. @\"text/plain; charset=utf-8\"@) -> L.ByteString -- ^ lazy bytestring content to send - -> Maybe (CalendarTime, Request) -- ^ mod-time for the bytestring, incoming request (used to check for if-modified-since header) + -> Maybe (UTCTime, Request) -- ^ mod-time for the bytestring, incoming request (used to check for if-modified-since header) -> Integer -- ^ offset into the bytestring -> Integer -- ^ number of bytes to send (offset + count must be less than or equal to the length of the bytestring) -> Response @@ -188,7 +189,7 @@ -- | Send the contents of a Lazy ByteString strictByteStringResponse :: String -- ^ content-type string (e.g. @\"text/plain; charset=utf-8\"@) -> S.ByteString -- ^ lazy bytestring content to send - -> Maybe (CalendarTime, Request) -- ^ mod-time for the bytestring, incoming request (used to check for if-modified-since header) + -> Maybe (UTCTime, Request) -- ^ mod-time for the bytestring, incoming request (used to check for if-modified-since header) -> Integer -- ^ offset into the bytestring -> Integer -- ^ number of bytes to send (offset + count must be less than or equal to the length of the bytestring) -> Response @@ -213,7 +214,7 @@ do count <- liftIO $ withBinaryFile fp ReadMode hFileSize -- garbage collection should close this modtime <- liftIO $ getModificationTime fp rq <- askRq - return $ sendFileResponse contentType fp (Just (toUTCTime modtime, rq)) 0 count + return $ sendFileResponse contentType fp (Just (modtime, rq)) 0 count -- | Send the specified file with the specified mime-type using lazy ByteStrings -- @@ -230,7 +231,7 @@ modtime <- liftIO $ getModificationTime fp count <- liftIO $ hFileSize handle rq <- askRq - return $ lazyByteStringResponse contentType contents (Just (toUTCTime modtime, rq)) 0 count + return $ lazyByteStringResponse contentType contents (Just (modtime, rq)) 0 count -- | Send the specified file with the specified mime-type using strict ByteStrings -- @@ -246,7 +247,7 @@ modtime <- liftIO $ getModificationTime fp count <- liftIO $ withBinaryFile fp ReadMode hFileSize rq <- askRq - return $ strictByteStringResponse contentType contents (Just (toUTCTime modtime, rq)) 0 count + return $ strictByteStringResponse contentType contents (Just (modtime, rq)) 0 count -- * High-level functions for serving files @@ -525,7 +526,7 @@ listing <- renderFn localPath $ filter (/= ".") (sort c) ok $ toResponse $ listing -data EntryKind = File | Directory | UnknownKind deriving (Eq, Ord, Read, Show, Data, Typeable, Enum) +data EntryKind = File | Directory | UnknownKind deriving (Eq, Ord, Read, Show, Data, Enum) -- | a function to generate an HTML page showing the contents of a directory on the disk -- @@ -566,7 +567,7 @@ -- a new page template to wrap around this HTML. -- -- see also: 'getMetaData', 'renderDirectoryContents' -renderDirectoryContentsTable :: [(FilePath, Maybe CalendarTime, Maybe Integer, EntryKind)] -- ^ list of files+meta data, see 'getMetaData' +renderDirectoryContentsTable :: [(FilePath, Maybe UTCTime, Maybe Integer, EntryKind)] -- ^ list of files+meta data, see 'getMetaData' -> H.Html renderDirectoryContentsTable fps = H.table $ do H.thead $ do H.th $ H.toHtml "" @@ -575,13 +576,13 @@ 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 :: ((FilePath, Maybe UTCTime, Maybe Integer, EntryKind), Bool) -> H.Html mkRow ((fp, modTime, count, kind), alt) = (if alt then (! A.class_ (H.toValue "alt")) else id) $ H.tr $ do H.td (mkKind kind) 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) + H.td ! A.class_ (H.toValue "date") $ (H.toHtml $ maybe "-" (formatTime 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 () @@ -605,16 +606,16 @@ -- | look up the meta data associated with a file getMetaData :: FilePath -- ^ path to directory on disk containing the entry -> FilePath -- ^ entry in that directory - -> IO (FilePath, Maybe CalendarTime, Maybe Integer, EntryKind) + -> IO (FilePath, Maybe UTCTime, Maybe Integer, EntryKind) getMetaData localPath fp = do let localFp = localPath fp - modTime <- (fmap Just . toCalendarTime =<< getModificationTime localFp) `catch` + modTime <- (Just <$> getModificationTime localFp) `E.catch` (\(_ :: 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) + `E.catch` (\(_e :: IOException) -> return Nothing) kind <- do fe <- doesFileExist localFp if fe then return File @@ -622,12 +623,12 @@ if de then return Directory else return UnknownKind - return (fp, modTime, count, kind) + return (if kind == Directory then (fp ++ "/") else fp, modTime, count, kind) -- | see 'serveDirectory' data Browsing = EnableBrowsing | DisableBrowsing - deriving (Eq, Enum, Ord, Read, Show, Data, Typeable) + deriving (Eq, Enum, Ord, Read, Show, Data) -- | Serve files and directories from a directory and its subdirectories using 'sendFile'. -- @@ -710,7 +711,6 @@ -- | Ready collection of common mime types. --- Except for the first two entries, the mappings come from an Ubuntu 8.04 \/etc\/mime.types file. +-- Except for the first two entries, the mappings come from http://svn.apache.org/viewvc/httpd/httpd/branches/2.4.x/docs/conf/mime.types?view=co mimeTypes :: MimeMap -mimeTypes = Map.fromList [("gz","application/x-gzip"),("cabal","application/x-cabal"),("%","application/x-trash"),("323","text/h323"),("3gp","video/3gpp"),("7z","application/x-7z-compressed"),("abw","application/x-abiword"),("ai","application/postscript"),("aif","audio/x-aiff"),("aifc","audio/x-aiff"),("aiff","audio/x-aiff"),("alc","chemical/x-alchemy"),("art","image/x-jg"),("asc","text/plain"),("asf","video/x-ms-asf"),("asn","chemical/x-ncbi-asn1"),("aso","chemical/x-ncbi-asn1-binary"),("asx","video/x-ms-asf"),("atom","application/atom"),("atomcat","application/atomcat+xml"),("atomsrv","application/atomserv+xml"),("au","audio/basic"),("avi","video/x-msvideo"),("b","chemical/x-molconn-Z"),("bak","application/x-trash"),("bat","application/x-msdos-program"),("bcpio","application/x-bcpio"),("bib","text/x-bibtex"),("bin","application/octet-stream"),("bmp","image/x-ms-bmp"),("boo","text/x-boo"),("book","application/x-maker"),("bsd","chemical/x-crossfire"),("c","text/x-csrc"),("c++","text/x-c++src"),("c3d","chemical/x-chem3d"),("cab","application/x-cab"),("cac","chemical/x-cache"),("cache","chemical/x-cache"),("cap","application/cap"),("cascii","chemical/x-cactvs-binary"),("cat","application/vnd.ms-pki.seccat"),("cbin","chemical/x-cactvs-binary"),("cbr","application/x-cbr"),("cbz","application/x-cbz"),("cc","text/x-c++src"),("cdf","application/x-cdf"),("cdr","image/x-coreldraw"),("cdt","image/x-coreldrawtemplate"),("cdx","chemical/x-cdx"),("cdy","application/vnd.cinderella"),("cef","chemical/x-cxf"),("cer","chemical/x-cerius"),("chm","chemical/x-chemdraw"),("chrt","application/x-kchart"),("cif","chemical/x-cif"),("class","application/java-vm"),("cls","text/x-tex"),("cmdf","chemical/x-cmdf"),("cml","chemical/x-cml"),("cod","application/vnd.rim.cod"),("com","application/x-msdos-program"),("cpa","chemical/x-compass"),("cpio","application/x-cpio"),("cpp","text/x-c++src"),("cpt","application/mac-compactpro"),("crl","application/x-pkcs7-crl"),("crt","application/x-x509-ca-cert"),("csf","chemical/x-cache-csf"),("csh","application/x-csh"),("csm","chemical/x-csml"),("csml","chemical/x-csml"),("css","text/css"),("csv","text/csv"),("ctab","chemical/x-cactvs-binary"),("ctx","chemical/x-ctx"),("cu","application/cu-seeme"),("cub","chemical/x-gaussian-cube"),("cxf","chemical/x-cxf"),("cxx","text/x-c++src"),("d","text/x-dsrc"),("dat","chemical/x-mopac-input"),("dcr","application/x-director"),("deb","application/x-debian-package"),("dif","video/dv"),("diff","text/x-diff"),("dir","application/x-director"),("djv","image/vnd.djvu"),("djvu","image/vnd.djvu"),("dl","video/dl"),("dll","application/x-msdos-program"),("dmg","application/x-apple-diskimage"),("dms","application/x-dms"),("doc","application/msword"),("dot","application/msword"),("dv","video/dv"),("dvi","application/x-dvi"),("dx","chemical/x-jcamp-dx"),("dxr","application/x-director"),("emb","chemical/x-embl-dl-nucleotide"),("embl","chemical/x-embl-dl-nucleotide"),("eml","message/rfc822"),("ent","chemical/x-ncbi-asn1-ascii"),("eps","application/postscript"),("etx","text/x-setext"),("exe","application/x-msdos-program"),("ez","application/andrew-inset"),("fb","application/x-maker"),("fbdoc","application/x-maker"),("fch","chemical/x-gaussian-checkpoint"),("fchk","chemical/x-gaussian-checkpoint"),("fig","application/x-xfig"),("flac","application/x-flac"),("fli","video/fli"),("fm","application/x-maker"),("frame","application/x-maker"),("frm","application/x-maker"),("gal","chemical/x-gaussian-log"),("gam","chemical/x-gamess-input"),("gamin","chemical/x-gamess-input"),("gau","chemical/x-gaussian-input"),("gcd","text/x-pcs-gcd"),("gcf","application/x-graphing-calculator"),("gcg","chemical/x-gcg8-sequence"),("gen","chemical/x-genbank"),("gf","application/x-tex-gf"),("gif","image/gif"),("gjc","chemical/x-gaussian-input"),("gjf","chemical/x-gaussian-input"),("gl","video/gl"),("gnumeric","application/x-gnumeric"),("gpt","chemical/x-mopac-graph"),("gsf","application/x-font"),("gsm","audio/x-gsm"),("gtar","application/x-gtar"),("h","text/x-chdr"),("h++","text/x-c++hdr"),("hdf","application/x-hdf"),("hh","text/x-c++hdr"),("hin","chemical/x-hin"),("hpp","text/x-c++hdr"),("hqx","application/mac-binhex40"),("hs","text/x-haskell"),("hta","application/hta"),("htc","text/x-component"),("htm","text/html"),("html","text/html"),("hxx","text/x-c++hdr"),("ica","application/x-ica"),("ice","x-conference/x-cooltalk"),("ico","image/x-icon"),("ics","text/calendar"),("icz","text/calendar"),("ief","image/ief"),("iges","model/iges"),("igs","model/iges"),("iii","application/x-iphone"),("inp","chemical/x-gamess-input"),("ins","application/x-internet-signup"),("iso","application/x-iso9660-image"),("isp","application/x-internet-signup"),("ist","chemical/x-isostar"),("istr","chemical/x-isostar"),("jad","text/vnd.sun.j2me.app-descriptor"),("jar","application/java-archive"),("java","text/x-java"),("jdx","chemical/x-jcamp-dx"),("jmz","application/x-jmol"),("jng","image/x-jng"),("jnlp","application/x-java-jnlp-file"),("jpe","image/jpeg"),("jpeg","image/jpeg"),("jpg","image/jpeg"),("js","application/x-javascript"),("kar","audio/midi"),("key","application/pgp-keys"),("kil","application/x-killustrator"),("kin","chemical/x-kinemage"),("kml","application/vnd.google-earth.kml+xml"),("kmz","application/vnd.google-earth.kmz"),("kpr","application/x-kpresenter"),("kpt","application/x-kpresenter"),("ksp","application/x-kspread"),("kwd","application/x-kword"),("kwt","application/x-kword"),("latex","application/x-latex"),("lha","application/x-lha"),("lhs","text/x-literate-haskell"),("lsf","video/x-la-asf"),("lsx","video/x-la-asf"),("ltx","text/x-tex"),("lyx","application/x-lyx"),("lzh","application/x-lzh"),("lzx","application/x-lzx"),("m3u","audio/mpegurl"),("m4a","audio/mpeg"),("maker","application/x-maker"),("man","application/x-troff-man"),("mcif","chemical/x-mmcif"),("mcm","chemical/x-macmolecule"),("mdb","application/msaccess"),("me","application/x-troff-me"),("mesh","model/mesh"),("mid","audio/midi"),("midi","audio/midi"),("mif","application/x-mif"),("mm","application/x-freemind"),("mmd","chemical/x-macromodel-input"),("mmf","application/vnd.smaf"),("mml","text/mathml"),("mmod","chemical/x-macromodel-input"),("mng","video/x-mng"),("moc","text/x-moc"),("mol","chemical/x-mdl-molfile"),("mol2","chemical/x-mol2"),("moo","chemical/x-mopac-out"),("mop","chemical/x-mopac-input"),("mopcrt","chemical/x-mopac-input"),("mov","video/quicktime"),("movie","video/x-sgi-movie"),("mp2","audio/mpeg"),("mp3","audio/mpeg"),("mp4","video/mp4"),("mpc","chemical/x-mopac-input"),("mpe","video/mpeg"),("mpeg","video/mpeg"),("mpega","audio/mpeg"),("mpg","video/mpeg"),("mpga","audio/mpeg"),("ms","application/x-troff-ms"),("msh","model/mesh"),("msi","application/x-msi"),("mvb","chemical/x-mopac-vib"),("mxu","video/vnd.mpegurl"),("nb","application/mathematica"),("nc","application/x-netcdf"),("nwc","application/x-nwc"),("o","application/x-object"),("oda","application/oda"),("odb","application/vnd.oasis.opendocument.database"),("odc","application/vnd.oasis.opendocument.chart"),("odf","application/vnd.oasis.opendocument.formula"),("odg","application/vnd.oasis.opendocument.graphics"),("odi","application/vnd.oasis.opendocument.image"),("odm","application/vnd.oasis.opendocument.text-master"),("odp","application/vnd.oasis.opendocument.presentation"),("ods","application/vnd.oasis.opendocument.spreadsheet"),("odt","application/vnd.oasis.opendocument.text"),("oga","audio/ogg"),("ogg","application/ogg"),("ogv","video/ogg"),("ogx","application/ogg"),("old","application/x-trash"),("otg","application/vnd.oasis.opendocument.graphics-template"),("oth","application/vnd.oasis.opendocument.text-web"),("otp","application/vnd.oasis.opendocument.presentation-template"),("ots","application/vnd.oasis.opendocument.spreadsheet-template"),("ott","application/vnd.oasis.opendocument.text-template"),("oza","application/x-oz-application"),("p","text/x-pascal"),("p7r","application/x-pkcs7-certreqresp"),("pac","application/x-ns-proxy-autoconfig"),("pas","text/x-pascal"),("pat","image/x-coreldrawpattern"),("patch","text/x-diff"),("pbm","image/x-portable-bitmap"),("pcap","application/cap"),("pcf","application/x-font"),("pcf.Z","application/x-font"),("pcx","image/pcx"),("pdb","chemical/x-pdb"),("pdf","application/pdf"),("pfa","application/x-font"),("pfb","application/x-font"),("pgm","image/x-portable-graymap"),("pgn","application/x-chess-pgn"),("pgp","application/pgp-signature"),("php","application/x-httpd-php"),("php3","application/x-httpd-php3"),("php3p","application/x-httpd-php3-preprocessed"),("php4","application/x-httpd-php4"),("phps","application/x-httpd-php-source"),("pht","application/x-httpd-php"),("phtml","application/x-httpd-php"),("pk","application/x-tex-pk"),("pl","text/x-perl"),("pls","audio/x-scpls"),("pm","text/x-perl"),("png","image/png"),("pnm","image/x-portable-anymap"),("pot","text/plain"),("ppm","image/x-portable-pixmap"),("pps","application/vnd.ms-powerpoint"),("ppt","application/vnd.ms-powerpoint"),("prf","application/pics-rules"),("prt","chemical/x-ncbi-asn1-ascii"),("ps","application/postscript"),("psd","image/x-photoshop"),("py","text/x-python"),("pyc","application/x-python-code"),("pyo","application/x-python-code"),("qt","video/quicktime"),("qtl","application/x-quicktimeplayer"),("ra","audio/x-pn-realaudio"),("ram","audio/x-pn-realaudio"),("rar","application/rar"),("ras","image/x-cmu-raster"),("rd","chemical/x-mdl-rdfile"),("rdf","application/rdf+xml"),("rgb","image/x-rgb"),("rhtml","application/x-httpd-eruby"),("rm","audio/x-pn-realaudio"),("roff","application/x-troff"),("ros","chemical/x-rosdal"),("rpm","application/x-redhat-package-manager"),("rss","application/rss+xml"),("rtf","application/rtf"),("rtx","text/richtext"),("rxn","chemical/x-mdl-rxnfile"),("sct","text/scriptlet"),("sd","chemical/x-mdl-sdfile"),("sd2","audio/x-sd2"),("sda","application/vnd.stardivision.draw"),("sdc","application/vnd.stardivision.calc"),("sdd","application/vnd.stardivision.impress"),("sdf","application/vnd.stardivision.math"),("sds","application/vnd.stardivision.chart"),("sdw","application/vnd.stardivision.writer"),("ser","application/java-serialized-object"),("sgf","application/x-go-sgf"),("sgl","application/vnd.stardivision.writer-global"),("sh","application/x-sh"),("shar","application/x-shar"),("shtml","text/html"),("sid","audio/prs.sid"),("sik","application/x-trash"),("silo","model/mesh"),("sis","application/vnd.symbian.install"),("sisx","x-epoc/x-sisx-app"),("sit","application/x-stuffit"),("sitx","application/x-stuffit"),("skd","application/x-koan"),("skm","application/x-koan"),("skp","application/x-koan"),("skt","application/x-koan"),("smi","application/smil"),("smil","application/smil"),("snd","audio/basic"),("spc","chemical/x-galactic-spc"),("spl","application/futuresplash"),("spx","audio/ogg"),("src","application/x-wais-source"),("stc","application/vnd.sun.xml.calc.template"),("std","application/vnd.sun.xml.draw.template"),("sti","application/vnd.sun.xml.impress.template"),("stl","application/vnd.ms-pki.stl"),("stw","application/vnd.sun.xml.writer.template"),("sty","text/x-tex"),("sv4cpio","application/x-sv4cpio"),("sv4crc","application/x-sv4crc"),("svg","image/svg+xml"),("svgz","image/svg+xml"),("sw","chemical/x-swissprot"),("swf","application/x-shockwave-flash"),("swfl","application/x-shockwave-flash"),("sxc","application/vnd.sun.xml.calc"),("sxd","application/vnd.sun.xml.draw"),("sxg","application/vnd.sun.xml.writer.global"),("sxi","application/vnd.sun.xml.impress"),("sxm","application/vnd.sun.xml.math"),("sxw","application/vnd.sun.xml.writer"),("t","application/x-troff"),("tar","application/x-tar"),("taz","application/x-gtar"),("tcl","application/x-tcl"),("tex","text/x-tex"),("texi","application/x-texinfo"),("texinfo","application/x-texinfo"),("text","text/plain"),("tgf","chemical/x-mdl-tgf"),("tgz","application/x-gtar"),("tif","image/tiff"),("tiff","image/tiff"),("tk","text/x-tcl"),("tm","text/texmacs"),("torrent","application/x-bittorrent"),("tr","application/x-troff"),("ts","text/texmacs"),("tsp","application/dsptype"),("tsv","text/tab-separated-values"),("txt","text/plain"),("udeb","application/x-debian-package"),("uls","text/iuls"),("ustar","application/x-ustar"),("val","chemical/x-ncbi-asn1-binary"),("vcd","application/x-cdlink"),("vcf","text/x-vcard"),("vcs","text/x-vcalendar"),("vmd","chemical/x-vmd"),("vms","chemical/x-vamas-iso14976"),("vrm","x-world/x-vrml"),("vrml","model/vrml"),("vsd","application/vnd.visio"),("wad","application/x-doom"),("wav","audio/x-wav"),("wax","audio/x-ms-wax"),("wbmp","image/vnd.wap.wbmp"),("wbxml","application/vnd.wap.wbxml"),("wk","application/x-123"),("wm","video/x-ms-wm"),("wma","audio/x-ms-wma"),("wmd","application/x-ms-wmd"),("wml","text/vnd.wap.wml"),("wmlc","application/vnd.wap.wmlc"),("wmls","text/vnd.wap.wmlscript"),("wmlsc","application/vnd.wap.wmlscriptc"),("wmv","video/x-ms-wmv"),("wmx","video/x-ms-wmx"),("wmz","application/x-ms-wmz"),("wp5","application/wordperfect5.1"),("wpd","application/wordperfect"),("wrl","model/vrml"),("wsc","text/scriptlet"),("wvx","video/x-ms-wvx"),("wz","application/x-wingz"),("xbm","image/x-xbitmap"),("xcf","application/x-xcf"),("xht","application/xhtml+xml"),("xhtml","application/xhtml+xml"),("xlb","application/vnd.ms-excel"),("xls","application/vnd.ms-excel"),("xlt","application/vnd.ms-excel"),("xml","application/xml"),("xpi","application/x-xpinstall"),("xpm","image/x-xpixmap"),("xsl","application/xml"),("xtel","chemical/x-xtel"),("xul","application/vnd.mozilla.xul+xml"),("xwd","image/x-xwindowdump"),("xyz","chemical/x-xyz"),("zip","application/zip"),("zmt","chemical/x-mopac-input"),("~","application/x-trash")] - +mimeTypes = Map.fromList [("gz","application/x-gzip"),("cabal","text/x-cabal"),("ez","application/andrew-inset"),("aw","application/applixware"),("atom","application/atom+xml"),("atomcat","application/atomcat+xml"),("atomsvc","application/atomsvc+xml"),("ccxml","application/ccxml+xml"),("cdmia","application/cdmi-capability"),("cdmic","application/cdmi-container"),("cdmid","application/cdmi-domain"),("cdmio","application/cdmi-object"),("cdmiq","application/cdmi-queue"),("cu","application/cu-seeme"),("davmount","application/davmount+xml"),("dbk","application/docbook+xml"),("dssc","application/dssc+der"),("xdssc","application/dssc+xml"),("ecma","application/ecmascript"),("emma","application/emma+xml"),("epub","application/epub+zip"),("exi","application/exi"),("pfr","application/font-tdpfr"),("gml","application/gml+xml"),("gpx","application/gpx+xml"),("gxf","application/gxf"),("stk","application/hyperstudio"),("ink","application/inkml+xml"),("inkml","application/inkml+xml"),("ipfix","application/ipfix"),("jar","application/java-archive"),("ser","application/java-serialized-object"),("class","application/java-vm"),("js","application/javascript"),("json","application/json"),("jsonml","application/jsonml+json"),("lostxml","application/lost+xml"),("hqx","application/mac-binhex40"),("cpt","application/mac-compactpro"),("mads","application/mads+xml"),("mrc","application/marc"),("mrcx","application/marcxml+xml"),("ma","application/mathematica"),("nb","application/mathematica"),("mb","application/mathematica"),("mathml","application/mathml+xml"),("mbox","application/mbox"),("mscml","application/mediaservercontrol+xml"),("metalink","application/metalink+xml"),("meta4","application/metalink4+xml"),("mets","application/mets+xml"),("mods","application/mods+xml"),("m21","application/mp21"),("mp21","application/mp21"),("mp4s","application/mp4"),("doc","application/msword"),("dot","application/msword"),("mxf","application/mxf"),("bin","application/octet-stream"),("dms","application/octet-stream"),("lrf","application/octet-stream"),("mar","application/octet-stream"),("so","application/octet-stream"),("dist","application/octet-stream"),("distz","application/octet-stream"),("pkg","application/octet-stream"),("bpk","application/octet-stream"),("dump","application/octet-stream"),("elc","application/octet-stream"),("deploy","application/octet-stream"),("oda","application/oda"),("opf","application/oebps-package+xml"),("ogx","application/ogg"),("omdoc","application/omdoc+xml"),("onetoc","application/onenote"),("onetoc2","application/onenote"),("onetmp","application/onenote"),("onepkg","application/onenote"),("oxps","application/oxps"),("xer","application/patch-ops-error+xml"),("pdf","application/pdf"),("pgp","application/pgp-encrypted"),("asc","application/pgp-signature"),("sig","application/pgp-signature"),("prf","application/pics-rules"),("p10","application/pkcs10"),("p7m","application/pkcs7-mime"),("p7c","application/pkcs7-mime"),("p7s","application/pkcs7-signature"),("p8","application/pkcs8"),("ac","application/pkix-attr-cert"),("cer","application/pkix-cert"),("crl","application/pkix-crl"),("pkipath","application/pkix-pkipath"),("pki","application/pkixcmp"),("pls","application/pls+xml"),("ai","application/postscript"),("eps","application/postscript"),("ps","application/postscript"),("cww","application/prs.cww"),("pskcxml","application/pskc+xml"),("rdf","application/rdf+xml"),("rif","application/reginfo+xml"),("rnc","application/relax-ng-compact-syntax"),("rl","application/resource-lists+xml"),("rld","application/resource-lists-diff+xml"),("rs","application/rls-services+xml"),("gbr","application/rpki-ghostbusters"),("mft","application/rpki-manifest"),("roa","application/rpki-roa"),("rsd","application/rsd+xml"),("rss","application/rss+xml"),("rtf","application/rtf"),("sbml","application/sbml+xml"),("scq","application/scvp-cv-request"),("scs","application/scvp-cv-response"),("spq","application/scvp-vp-request"),("spp","application/scvp-vp-response"),("sdp","application/sdp"),("setpay","application/set-payment-initiation"),("setreg","application/set-registration-initiation"),("shf","application/shf+xml"),("smi","application/smil+xml"),("smil","application/smil+xml"),("rq","application/sparql-query"),("srx","application/sparql-results+xml"),("gram","application/srgs"),("grxml","application/srgs+xml"),("sru","application/sru+xml"),("ssdl","application/ssdl+xml"),("ssml","application/ssml+xml"),("tei","application/tei+xml"),("teicorpus","application/tei+xml"),("tfi","application/thraud+xml"),("tsd","application/timestamped-data"),("plb","application/vnd.3gpp.pic-bw-large"),("psb","application/vnd.3gpp.pic-bw-small"),("pvb","application/vnd.3gpp.pic-bw-var"),("tcap","application/vnd.3gpp2.tcap"),("pwn","application/vnd.3m.post-it-notes"),("aso","application/vnd.accpac.simply.aso"),("imp","application/vnd.accpac.simply.imp"),("acu","application/vnd.acucobol"),("atc","application/vnd.acucorp"),("acutc","application/vnd.acucorp"),("air","application/vnd.adobe.air-application-installer-package+zip"),("fcdt","application/vnd.adobe.formscentral.fcdt"),("fxp","application/vnd.adobe.fxp"),("fxpl","application/vnd.adobe.fxp"),("xdp","application/vnd.adobe.xdp+xml"),("xfdf","application/vnd.adobe.xfdf"),("ahead","application/vnd.ahead.space"),("azf","application/vnd.airzip.filesecure.azf"),("azs","application/vnd.airzip.filesecure.azs"),("azw","application/vnd.amazon.ebook"),("acc","application/vnd.americandynamics.acc"),("ami","application/vnd.amiga.ami"),("apk","application/vnd.android.package-archive"),("cii","application/vnd.anser-web-certificate-issue-initiation"),("fti","application/vnd.anser-web-funds-transfer-initiation"),("atx","application/vnd.antix.game-component"),("mpkg","application/vnd.apple.installer+xml"),("m3u8","application/vnd.apple.mpegurl"),("swi","application/vnd.aristanetworks.swi"),("iota","application/vnd.astraea-software.iota"),("aep","application/vnd.audiograph"),("mpm","application/vnd.blueice.multipass"),("bmi","application/vnd.bmi"),("rep","application/vnd.businessobjects"),("cdxml","application/vnd.chemdraw+xml"),("mmd","application/vnd.chipnuts.karaoke-mmd"),("cdy","application/vnd.cinderella"),("cla","application/vnd.claymore"),("rp9","application/vnd.cloanto.rp9"),("c4g","application/vnd.clonk.c4group"),("c4d","application/vnd.clonk.c4group"),("c4f","application/vnd.clonk.c4group"),("c4p","application/vnd.clonk.c4group"),("c4u","application/vnd.clonk.c4group"),("c11amc","application/vnd.cluetrust.cartomobile-config"),("c11amz","application/vnd.cluetrust.cartomobile-config-pkg"),("csp","application/vnd.commonspace"),("cdbcmsg","application/vnd.contact.cmsg"),("cmc","application/vnd.cosmocaller"),("clkx","application/vnd.crick.clicker"),("clkk","application/vnd.crick.clicker.keyboard"),("clkp","application/vnd.crick.clicker.palette"),("clkt","application/vnd.crick.clicker.template"),("clkw","application/vnd.crick.clicker.wordbank"),("wbs","application/vnd.criticaltools.wbs+xml"),("pml","application/vnd.ctc-posml"),("ppd","application/vnd.cups-ppd"),("car","application/vnd.curl.car"),("pcurl","application/vnd.curl.pcurl"),("dart","application/vnd.dart"),("rdz","application/vnd.data-vision.rdz"),("uvf","application/vnd.dece.data"),("uvvf","application/vnd.dece.data"),("uvd","application/vnd.dece.data"),("uvvd","application/vnd.dece.data"),("uvt","application/vnd.dece.ttml+xml"),("uvvt","application/vnd.dece.ttml+xml"),("uvx","application/vnd.dece.unspecified"),("uvvx","application/vnd.dece.unspecified"),("uvz","application/vnd.dece.zip"),("uvvz","application/vnd.dece.zip"),("fe_launch","application/vnd.denovo.fcselayout-link"),("dna","application/vnd.dna"),("mlp","application/vnd.dolby.mlp"),("dpg","application/vnd.dpgraph"),("dfac","application/vnd.dreamfactory"),("kpxx","application/vnd.ds-keypoint"),("ait","application/vnd.dvb.ait"),("svc","application/vnd.dvb.service"),("geo","application/vnd.dynageo"),("mag","application/vnd.ecowin.chart"),("nml","application/vnd.enliven"),("esf","application/vnd.epson.esf"),("msf","application/vnd.epson.msf"),("qam","application/vnd.epson.quickanime"),("slt","application/vnd.epson.salt"),("ssf","application/vnd.epson.ssf"),("es3","application/vnd.eszigno3+xml"),("et3","application/vnd.eszigno3+xml"),("ez2","application/vnd.ezpix-album"),("ez3","application/vnd.ezpix-package"),("fdf","application/vnd.fdf"),("mseed","application/vnd.fdsn.mseed"),("seed","application/vnd.fdsn.seed"),("dataless","application/vnd.fdsn.seed"),("gph","application/vnd.flographit"),("ftc","application/vnd.fluxtime.clip"),("fm","application/vnd.framemaker"),("frame","application/vnd.framemaker"),("maker","application/vnd.framemaker"),("book","application/vnd.framemaker"),("fnc","application/vnd.frogans.fnc"),("ltf","application/vnd.frogans.ltf"),("fsc","application/vnd.fsc.weblaunch"),("oas","application/vnd.fujitsu.oasys"),("oa2","application/vnd.fujitsu.oasys2"),("oa3","application/vnd.fujitsu.oasys3"),("fg5","application/vnd.fujitsu.oasysgp"),("bh2","application/vnd.fujitsu.oasysprs"),("ddd","application/vnd.fujixerox.ddd"),("xdw","application/vnd.fujixerox.docuworks"),("xbd","application/vnd.fujixerox.docuworks.binder"),("fzs","application/vnd.fuzzysheet"),("txd","application/vnd.genomatix.tuxedo"),("ggb","application/vnd.geogebra.file"),("ggt","application/vnd.geogebra.tool"),("gex","application/vnd.geometry-explorer"),("gre","application/vnd.geometry-explorer"),("gxt","application/vnd.geonext"),("g2w","application/vnd.geoplan"),("g3w","application/vnd.geospace"),("gmx","application/vnd.gmx"),("kml","application/vnd.google-earth.kml+xml"),("kmz","application/vnd.google-earth.kmz"),("gqf","application/vnd.grafeq"),("gqs","application/vnd.grafeq"),("gac","application/vnd.groove-account"),("ghf","application/vnd.groove-help"),("gim","application/vnd.groove-identity-message"),("grv","application/vnd.groove-injector"),("gtm","application/vnd.groove-tool-message"),("tpl","application/vnd.groove-tool-template"),("vcg","application/vnd.groove-vcard"),("hal","application/vnd.hal+xml"),("zmm","application/vnd.handheld-entertainment+xml"),("hbci","application/vnd.hbci"),("les","application/vnd.hhe.lesson-player"),("hpgl","application/vnd.hp-hpgl"),("hpid","application/vnd.hp-hpid"),("hps","application/vnd.hp-hps"),("jlt","application/vnd.hp-jlyt"),("pcl","application/vnd.hp-pcl"),("pclxl","application/vnd.hp-pclxl"),("sfd-hdstx","application/vnd.hydrostatix.sof-data"),("mpy","application/vnd.ibm.minipay"),("afp","application/vnd.ibm.modcap"),("listafp","application/vnd.ibm.modcap"),("list3820","application/vnd.ibm.modcap"),("irm","application/vnd.ibm.rights-management"),("sc","application/vnd.ibm.secure-container"),("icc","application/vnd.iccprofile"),("icm","application/vnd.iccprofile"),("igl","application/vnd.igloader"),("ivp","application/vnd.immervision-ivp"),("ivu","application/vnd.immervision-ivu"),("igm","application/vnd.insors.igm"),("xpw","application/vnd.intercon.formnet"),("xpx","application/vnd.intercon.formnet"),("i2g","application/vnd.intergeo"),("qbo","application/vnd.intu.qbo"),("qfx","application/vnd.intu.qfx"),("rcprofile","application/vnd.ipunplugged.rcprofile"),("irp","application/vnd.irepository.package+xml"),("xpr","application/vnd.is-xpr"),("fcs","application/vnd.isac.fcs"),("jam","application/vnd.jam"),("rms","application/vnd.jcp.javame.midlet-rms"),("jisp","application/vnd.jisp"),("joda","application/vnd.joost.joda-archive"),("ktz","application/vnd.kahootz"),("ktr","application/vnd.kahootz"),("karbon","application/vnd.kde.karbon"),("chrt","application/vnd.kde.kchart"),("kfo","application/vnd.kde.kformula"),("flw","application/vnd.kde.kivio"),("kon","application/vnd.kde.kontour"),("kpr","application/vnd.kde.kpresenter"),("kpt","application/vnd.kde.kpresenter"),("ksp","application/vnd.kde.kspread"),("kwd","application/vnd.kde.kword"),("kwt","application/vnd.kde.kword"),("htke","application/vnd.kenameaapp"),("kia","application/vnd.kidspiration"),("kne","application/vnd.kinar"),("knp","application/vnd.kinar"),("skp","application/vnd.koan"),("skd","application/vnd.koan"),("skt","application/vnd.koan"),("skm","application/vnd.koan"),("sse","application/vnd.kodak-descriptor"),("lasxml","application/vnd.las.las+xml"),("lbd","application/vnd.llamagraphics.life-balance.desktop"),("lbe","application/vnd.llamagraphics.life-balance.exchange+xml"),("123","application/vnd.lotus-1-2-3"),("apr","application/vnd.lotus-approach"),("pre","application/vnd.lotus-freelance"),("nsf","application/vnd.lotus-notes"),("org","application/vnd.lotus-organizer"),("scm","application/vnd.lotus-screencam"),("lwp","application/vnd.lotus-wordpro"),("portpkg","application/vnd.macports.portpkg"),("mcd","application/vnd.mcd"),("mc1","application/vnd.medcalcdata"),("cdkey","application/vnd.mediastation.cdkey"),("mwf","application/vnd.mfer"),("mfm","application/vnd.mfmp"),("flo","application/vnd.micrografx.flo"),("igx","application/vnd.micrografx.igx"),("mif","application/vnd.mif"),("daf","application/vnd.mobius.daf"),("dis","application/vnd.mobius.dis"),("mbk","application/vnd.mobius.mbk"),("mqy","application/vnd.mobius.mqy"),("msl","application/vnd.mobius.msl"),("plc","application/vnd.mobius.plc"),("txf","application/vnd.mobius.txf"),("mpn","application/vnd.mophun.application"),("mpc","application/vnd.mophun.certificate"),("xul","application/vnd.mozilla.xul+xml"),("cil","application/vnd.ms-artgalry"),("cab","application/vnd.ms-cab-compressed"),("xls","application/vnd.ms-excel"),("xlm","application/vnd.ms-excel"),("xla","application/vnd.ms-excel"),("xlc","application/vnd.ms-excel"),("xlt","application/vnd.ms-excel"),("xlw","application/vnd.ms-excel"),("xlam","application/vnd.ms-excel.addin.macroenabled.12"),("xlsb","application/vnd.ms-excel.sheet.binary.macroenabled.12"),("xlsm","application/vnd.ms-excel.sheet.macroenabled.12"),("xltm","application/vnd.ms-excel.template.macroenabled.12"),("eot","application/vnd.ms-fontobject"),("chm","application/vnd.ms-htmlhelp"),("ims","application/vnd.ms-ims"),("lrm","application/vnd.ms-lrm"),("thmx","application/vnd.ms-officetheme"),("cat","application/vnd.ms-pki.seccat"),("stl","application/vnd.ms-pki.stl"),("ppt","application/vnd.ms-powerpoint"),("pps","application/vnd.ms-powerpoint"),("pot","application/vnd.ms-powerpoint"),("ppam","application/vnd.ms-powerpoint.addin.macroenabled.12"),("pptm","application/vnd.ms-powerpoint.presentation.macroenabled.12"),("sldm","application/vnd.ms-powerpoint.slide.macroenabled.12"),("ppsm","application/vnd.ms-powerpoint.slideshow.macroenabled.12"),("potm","application/vnd.ms-powerpoint.template.macroenabled.12"),("mpp","application/vnd.ms-project"),("mpt","application/vnd.ms-project"),("docm","application/vnd.ms-word.document.macroenabled.12"),("dotm","application/vnd.ms-word.template.macroenabled.12"),("wps","application/vnd.ms-works"),("wks","application/vnd.ms-works"),("wcm","application/vnd.ms-works"),("wdb","application/vnd.ms-works"),("wpl","application/vnd.ms-wpl"),("xps","application/vnd.ms-xpsdocument"),("mseq","application/vnd.mseq"),("mus","application/vnd.musician"),("msty","application/vnd.muvee.style"),("taglet","application/vnd.mynfc"),("nlu","application/vnd.neurolanguage.nlu"),("ntf","application/vnd.nitf"),("nitf","application/vnd.nitf"),("nnd","application/vnd.noblenet-directory"),("nns","application/vnd.noblenet-sealer"),("nnw","application/vnd.noblenet-web"),("ngdat","application/vnd.nokia.n-gage.data"),("n-gage","application/vnd.nokia.n-gage.symbian.install"),("rpst","application/vnd.nokia.radio-preset"),("rpss","application/vnd.nokia.radio-presets"),("edm","application/vnd.novadigm.edm"),("edx","application/vnd.novadigm.edx"),("ext","application/vnd.novadigm.ext"),("odc","application/vnd.oasis.opendocument.chart"),("otc","application/vnd.oasis.opendocument.chart-template"),("odb","application/vnd.oasis.opendocument.database"),("odf","application/vnd.oasis.opendocument.formula"),("odft","application/vnd.oasis.opendocument.formula-template"),("odg","application/vnd.oasis.opendocument.graphics"),("otg","application/vnd.oasis.opendocument.graphics-template"),("odi","application/vnd.oasis.opendocument.image"),("oti","application/vnd.oasis.opendocument.image-template"),("odp","application/vnd.oasis.opendocument.presentation"),("otp","application/vnd.oasis.opendocument.presentation-template"),("ods","application/vnd.oasis.opendocument.spreadsheet"),("ots","application/vnd.oasis.opendocument.spreadsheet-template"),("odt","application/vnd.oasis.opendocument.text"),("odm","application/vnd.oasis.opendocument.text-master"),("ott","application/vnd.oasis.opendocument.text-template"),("oth","application/vnd.oasis.opendocument.text-web"),("xo","application/vnd.olpc-sugar"),("dd2","application/vnd.oma.dd2+xml"),("oxt","application/vnd.openofficeorg.extension"),("pptx","application/vnd.openxmlformats-officedocument.presentationml.presentation"),("sldx","application/vnd.openxmlformats-officedocument.presentationml.slide"),("ppsx","application/vnd.openxmlformats-officedocument.presentationml.slideshow"),("potx","application/vnd.openxmlformats-officedocument.presentationml.template"),("xlsx","application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"),("xltx","application/vnd.openxmlformats-officedocument.spreadsheetml.template"),("docx","application/vnd.openxmlformats-officedocument.wordprocessingml.document"),("dotx","application/vnd.openxmlformats-officedocument.wordprocessingml.template"),("mgp","application/vnd.osgeo.mapguide.package"),("dp","application/vnd.osgi.dp"),("esa","application/vnd.osgi.subsystem"),("pdb","application/vnd.palm"),("pqa","application/vnd.palm"),("oprc","application/vnd.palm"),("paw","application/vnd.pawaafile"),("str","application/vnd.pg.format"),("ei6","application/vnd.pg.osasli"),("efif","application/vnd.picsel"),("wg","application/vnd.pmi.widget"),("plf","application/vnd.pocketlearn"),("pbd","application/vnd.powerbuilder6"),("box","application/vnd.previewsystems.box"),("mgz","application/vnd.proteus.magazine"),("qps","application/vnd.publishare-delta-tree"),("ptid","application/vnd.pvi.ptid1"),("qxd","application/vnd.quark.quarkxpress"),("qxt","application/vnd.quark.quarkxpress"),("qwd","application/vnd.quark.quarkxpress"),("qwt","application/vnd.quark.quarkxpress"),("qxl","application/vnd.quark.quarkxpress"),("qxb","application/vnd.quark.quarkxpress"),("bed","application/vnd.realvnc.bed"),("mxl","application/vnd.recordare.musicxml"),("musicxml","application/vnd.recordare.musicxml+xml"),("cryptonote","application/vnd.rig.cryptonote"),("cod","application/vnd.rim.cod"),("rm","application/vnd.rn-realmedia"),("rmvb","application/vnd.rn-realmedia-vbr"),("link66","application/vnd.route66.link66+xml"),("st","application/vnd.sailingtracker.track"),("see","application/vnd.seemail"),("sema","application/vnd.sema"),("semd","application/vnd.semd"),("semf","application/vnd.semf"),("ifm","application/vnd.shana.informed.formdata"),("itp","application/vnd.shana.informed.formtemplate"),("iif","application/vnd.shana.informed.interchange"),("ipk","application/vnd.shana.informed.package"),("twd","application/vnd.simtech-mindmapper"),("twds","application/vnd.simtech-mindmapper"),("mmf","application/vnd.smaf"),("teacher","application/vnd.smart.teacher"),("sdkm","application/vnd.solent.sdkm+xml"),("sdkd","application/vnd.solent.sdkm+xml"),("dxp","application/vnd.spotfire.dxp"),("sfs","application/vnd.spotfire.sfs"),("sdc","application/vnd.stardivision.calc"),("sda","application/vnd.stardivision.draw"),("sdd","application/vnd.stardivision.impress"),("smf","application/vnd.stardivision.math"),("sdw","application/vnd.stardivision.writer"),("vor","application/vnd.stardivision.writer"),("sgl","application/vnd.stardivision.writer-global"),("smzip","application/vnd.stepmania.package"),("sm","application/vnd.stepmania.stepchart"),("sxc","application/vnd.sun.xml.calc"),("stc","application/vnd.sun.xml.calc.template"),("sxd","application/vnd.sun.xml.draw"),("std","application/vnd.sun.xml.draw.template"),("sxi","application/vnd.sun.xml.impress"),("sti","application/vnd.sun.xml.impress.template"),("sxm","application/vnd.sun.xml.math"),("sxw","application/vnd.sun.xml.writer"),("sxg","application/vnd.sun.xml.writer.global"),("stw","application/vnd.sun.xml.writer.template"),("sus","application/vnd.sus-calendar"),("susp","application/vnd.sus-calendar"),("svd","application/vnd.svd"),("sis","application/vnd.symbian.install"),("sisx","application/vnd.symbian.install"),("xsm","application/vnd.syncml+xml"),("bdm","application/vnd.syncml.dm+wbxml"),("xdm","application/vnd.syncml.dm+xml"),("tao","application/vnd.tao.intent-module-archive"),("pcap","application/vnd.tcpdump.pcap"),("cap","application/vnd.tcpdump.pcap"),("dmp","application/vnd.tcpdump.pcap"),("tmo","application/vnd.tmobile-livetv"),("tpt","application/vnd.trid.tpt"),("mxs","application/vnd.triscape.mxs"),("tra","application/vnd.trueapp"),("ufd","application/vnd.ufdl"),("ufdl","application/vnd.ufdl"),("utz","application/vnd.uiq.theme"),("umj","application/vnd.umajin"),("unityweb","application/vnd.unity"),("uoml","application/vnd.uoml+xml"),("vcx","application/vnd.vcx"),("vsd","application/vnd.visio"),("vst","application/vnd.visio"),("vss","application/vnd.visio"),("vsw","application/vnd.visio"),("vis","application/vnd.visionary"),("vsf","application/vnd.vsf"),("wbxml","application/vnd.wap.wbxml"),("wmlc","application/vnd.wap.wmlc"),("wmlsc","application/vnd.wap.wmlscriptc"),("wtb","application/vnd.webturbo"),("nbp","application/vnd.wolfram.player"),("wpd","application/vnd.wordperfect"),("wqd","application/vnd.wqd"),("stf","application/vnd.wt.stf"),("xar","application/vnd.xara"),("xfdl","application/vnd.xfdl"),("hvd","application/vnd.yamaha.hv-dic"),("hvs","application/vnd.yamaha.hv-script"),("hvp","application/vnd.yamaha.hv-voice"),("osf","application/vnd.yamaha.openscoreformat"),("osfpvg","application/vnd.yamaha.openscoreformat.osfpvg+xml"),("saf","application/vnd.yamaha.smaf-audio"),("spf","application/vnd.yamaha.smaf-phrase"),("cmp","application/vnd.yellowriver-custom-menu"),("zir","application/vnd.zul"),("zirz","application/vnd.zul"),("zaz","application/vnd.zzazz.deck+xml"),("vxml","application/voicexml+xml"),("wgt","application/widget"),("hlp","application/winhlp"),("wsdl","application/wsdl+xml"),("wspolicy","application/wspolicy+xml"),("7z","application/x-7z-compressed"),("abw","application/x-abiword"),("ace","application/x-ace-compressed"),("dmg","application/x-apple-diskimage"),("aab","application/x-authorware-bin"),("x32","application/x-authorware-bin"),("u32","application/x-authorware-bin"),("vox","application/x-authorware-bin"),("aam","application/x-authorware-map"),("aas","application/x-authorware-seg"),("bcpio","application/x-bcpio"),("torrent","application/x-bittorrent"),("blb","application/x-blorb"),("blorb","application/x-blorb"),("bz","application/x-bzip"),("bz2","application/x-bzip2"),("boz","application/x-bzip2"),("cbr","application/x-cbr"),("cba","application/x-cbr"),("cbt","application/x-cbr"),("cbz","application/x-cbr"),("cb7","application/x-cbr"),("vcd","application/x-cdlink"),("cfs","application/x-cfs-compressed"),("chat","application/x-chat"),("pgn","application/x-chess-pgn"),("nsc","application/x-conference"),("cpio","application/x-cpio"),("csh","application/x-csh"),("deb","application/x-debian-package"),("udeb","application/x-debian-package"),("dgc","application/x-dgc-compressed"),("dir","application/x-director"),("dcr","application/x-director"),("dxr","application/x-director"),("cst","application/x-director"),("cct","application/x-director"),("cxt","application/x-director"),("w3d","application/x-director"),("fgd","application/x-director"),("swa","application/x-director"),("wad","application/x-doom"),("ncx","application/x-dtbncx+xml"),("dtb","application/x-dtbook+xml"),("res","application/x-dtbresource+xml"),("dvi","application/x-dvi"),("evy","application/x-envoy"),("eva","application/x-eva"),("bdf","application/x-font-bdf"),("gsf","application/x-font-ghostscript"),("psf","application/x-font-linux-psf"),("pcf","application/x-font-pcf"),("snf","application/x-font-snf"),("pfa","application/x-font-type1"),("pfb","application/x-font-type1"),("pfm","application/x-font-type1"),("afm","application/x-font-type1"),("arc","application/x-freearc"),("spl","application/x-futuresplash"),("gca","application/x-gca-compressed"),("ulx","application/x-glulx"),("gnumeric","application/x-gnumeric"),("gramps","application/x-gramps-xml"),("gtar","application/x-gtar"),("hdf","application/x-hdf"),("install","application/x-install-instructions"),("iso","application/x-iso9660-image"),("jnlp","application/x-java-jnlp-file"),("latex","application/x-latex"),("lzh","application/x-lzh-compressed"),("lha","application/x-lzh-compressed"),("mie","application/x-mie"),("prc","application/x-mobipocket-ebook"),("mobi","application/x-mobipocket-ebook"),("application","application/x-ms-application"),("lnk","application/x-ms-shortcut"),("wmd","application/x-ms-wmd"),("wmz","application/x-ms-wmz"),("xbap","application/x-ms-xbap"),("mdb","application/x-msaccess"),("obd","application/x-msbinder"),("crd","application/x-mscardfile"),("clp","application/x-msclip"),("exe","application/x-msdownload"),("dll","application/x-msdownload"),("com","application/x-msdownload"),("bat","application/x-msdownload"),("msi","application/x-msdownload"),("mvb","application/x-msmediaview"),("m13","application/x-msmediaview"),("m14","application/x-msmediaview"),("wmf","application/x-msmetafile"),("wmz","application/x-msmetafile"),("emf","application/x-msmetafile"),("emz","application/x-msmetafile"),("mny","application/x-msmoney"),("pub","application/x-mspublisher"),("scd","application/x-msschedule"),("trm","application/x-msterminal"),("wri","application/x-mswrite"),("nc","application/x-netcdf"),("cdf","application/x-netcdf"),("nzb","application/x-nzb"),("p12","application/x-pkcs12"),("pfx","application/x-pkcs12"),("p7b","application/x-pkcs7-certificates"),("spc","application/x-pkcs7-certificates"),("p7r","application/x-pkcs7-certreqresp"),("rar","application/x-rar-compressed"),("ris","application/x-research-info-systems"),("sh","application/x-sh"),("shar","application/x-shar"),("swf","application/x-shockwave-flash"),("xap","application/x-silverlight-app"),("sql","application/x-sql"),("sit","application/x-stuffit"),("sitx","application/x-stuffitx"),("srt","application/x-subrip"),("sv4cpio","application/x-sv4cpio"),("sv4crc","application/x-sv4crc"),("t3","application/x-t3vm-image"),("gam","application/x-tads"),("tar","application/x-tar"),("tcl","application/x-tcl"),("tex","application/x-tex"),("tfm","application/x-tex-tfm"),("texinfo","application/x-texinfo"),("texi","application/x-texinfo"),("obj","application/x-tgif"),("ustar","application/x-ustar"),("src","application/x-wais-source"),("der","application/x-x509-ca-cert"),("crt","application/x-x509-ca-cert"),("fig","application/x-xfig"),("xlf","application/x-xliff+xml"),("xpi","application/x-xpinstall"),("xz","application/x-xz"),("z1","application/x-zmachine"),("z2","application/x-zmachine"),("z3","application/x-zmachine"),("z4","application/x-zmachine"),("z5","application/x-zmachine"),("z6","application/x-zmachine"),("z7","application/x-zmachine"),("z8","application/x-zmachine"),("xaml","application/xaml+xml"),("xdf","application/xcap-diff+xml"),("xenc","application/xenc+xml"),("xhtml","application/xhtml+xml"),("xht","application/xhtml+xml"),("xml","application/xml"),("xsl","application/xml"),("dtd","application/xml-dtd"),("xop","application/xop+xml"),("xpl","application/xproc+xml"),("xslt","application/xslt+xml"),("xspf","application/xspf+xml"),("mxml","application/xv+xml"),("xhvml","application/xv+xml"),("xvml","application/xv+xml"),("xvm","application/xv+xml"),("yang","application/yang"),("yin","application/yin+xml"),("zip","application/zip"),("adp","audio/adpcm"),("au","audio/basic"),("snd","audio/basic"),("mid","audio/midi"),("midi","audio/midi"),("kar","audio/midi"),("rmi","audio/midi"),("m4a","audio/mp4"),("mp4a","audio/mp4"),("mpga","audio/mpeg"),("mp2","audio/mpeg"),("mp2a","audio/mpeg"),("mp3","audio/mpeg"),("m2a","audio/mpeg"),("m3a","audio/mpeg"),("oga","audio/ogg"),("ogg","audio/ogg"),("spx","audio/ogg"),("s3m","audio/s3m"),("sil","audio/silk"),("uva","audio/vnd.dece.audio"),("uvva","audio/vnd.dece.audio"),("eol","audio/vnd.digital-winds"),("dra","audio/vnd.dra"),("dts","audio/vnd.dts"),("dtshd","audio/vnd.dts.hd"),("lvp","audio/vnd.lucent.voice"),("pya","audio/vnd.ms-playready.media.pya"),("ecelp4800","audio/vnd.nuera.ecelp4800"),("ecelp7470","audio/vnd.nuera.ecelp7470"),("ecelp9600","audio/vnd.nuera.ecelp9600"),("rip","audio/vnd.rip"),("weba","audio/webm"),("aac","audio/x-aac"),("aif","audio/x-aiff"),("aiff","audio/x-aiff"),("aifc","audio/x-aiff"),("caf","audio/x-caf"),("flac","audio/x-flac"),("mka","audio/x-matroska"),("m3u","audio/x-mpegurl"),("wax","audio/x-ms-wax"),("wma","audio/x-ms-wma"),("ram","audio/x-pn-realaudio"),("ra","audio/x-pn-realaudio"),("rmp","audio/x-pn-realaudio-plugin"),("wav","audio/x-wav"),("xm","audio/xm"),("cdx","chemical/x-cdx"),("cif","chemical/x-cif"),("cmdf","chemical/x-cmdf"),("cml","chemical/x-cml"),("csml","chemical/x-csml"),("xyz","chemical/x-xyz"),("ttc","font/collection"),("otf","font/otf"),("ttf","font/ttf"),("woff","font/woff"),("woff2","font/woff2"),("bmp","image/bmp"),("cgm","image/cgm"),("g3","image/g3fax"),("gif","image/gif"),("ief","image/ief"),("jpeg","image/jpeg"),("jpg","image/jpeg"),("jpe","image/jpeg"),("ktx","image/ktx"),("png","image/png"),("btif","image/prs.btif"),("sgi","image/sgi"),("svg","image/svg+xml"),("svgz","image/svg+xml"),("tiff","image/tiff"),("tif","image/tiff"),("psd","image/vnd.adobe.photoshop"),("uvi","image/vnd.dece.graphic"),("uvvi","image/vnd.dece.graphic"),("uvg","image/vnd.dece.graphic"),("uvvg","image/vnd.dece.graphic"),("djvu","image/vnd.djvu"),("djv","image/vnd.djvu"),("sub","image/vnd.dvb.subtitle"),("dwg","image/vnd.dwg"),("dxf","image/vnd.dxf"),("fbs","image/vnd.fastbidsheet"),("fpx","image/vnd.fpx"),("fst","image/vnd.fst"),("mmr","image/vnd.fujixerox.edmics-mmr"),("rlc","image/vnd.fujixerox.edmics-rlc"),("mdi","image/vnd.ms-modi"),("wdp","image/vnd.ms-photo"),("npx","image/vnd.net-fpx"),("wbmp","image/vnd.wap.wbmp"),("xif","image/vnd.xiff"),("webp","image/webp"),("3ds","image/x-3ds"),("ras","image/x-cmu-raster"),("cmx","image/x-cmx"),("fh","image/x-freehand"),("fhc","image/x-freehand"),("fh4","image/x-freehand"),("fh5","image/x-freehand"),("fh7","image/x-freehand"),("ico","image/x-icon"),("sid","image/x-mrsid-image"),("pcx","image/x-pcx"),("pic","image/x-pict"),("pct","image/x-pict"),("pnm","image/x-portable-anymap"),("pbm","image/x-portable-bitmap"),("pgm","image/x-portable-graymap"),("ppm","image/x-portable-pixmap"),("rgb","image/x-rgb"),("tga","image/x-tga"),("xbm","image/x-xbitmap"),("xpm","image/x-xpixmap"),("xwd","image/x-xwindowdump"),("eml","message/rfc822"),("mime","message/rfc822"),("igs","model/iges"),("iges","model/iges"),("msh","model/mesh"),("mesh","model/mesh"),("silo","model/mesh"),("dae","model/vnd.collada+xml"),("dwf","model/vnd.dwf"),("gdl","model/vnd.gdl"),("gtw","model/vnd.gtw"),("mts","model/vnd.mts"),("vtu","model/vnd.vtu"),("wrl","model/vrml"),("vrml","model/vrml"),("x3db","model/x3d+binary"),("x3dbz","model/x3d+binary"),("x3dv","model/x3d+vrml"),("x3dvz","model/x3d+vrml"),("x3d","model/x3d+xml"),("x3dz","model/x3d+xml"),("appcache","text/cache-manifest"),("ics","text/calendar"),("ifb","text/calendar"),("css","text/css"),("csv","text/csv"),("html","text/html"),("htm","text/html"),("n3","text/n3"),("txt","text/plain"),("text","text/plain"),("conf","text/plain"),("def","text/plain"),("list","text/plain"),("log","text/plain"),("in","text/plain"),("dsc","text/prs.lines.tag"),("rtx","text/richtext"),("sgml","text/sgml"),("sgm","text/sgml"),("tsv","text/tab-separated-values"),("t","text/troff"),("tr","text/troff"),("roff","text/troff"),("man","text/troff"),("me","text/troff"),("ms","text/troff"),("ttl","text/turtle"),("uri","text/uri-list"),("uris","text/uri-list"),("urls","text/uri-list"),("vcard","text/vcard"),("curl","text/vnd.curl"),("dcurl","text/vnd.curl.dcurl"),("mcurl","text/vnd.curl.mcurl"),("scurl","text/vnd.curl.scurl"),("sub","text/vnd.dvb.subtitle"),("fly","text/vnd.fly"),("flx","text/vnd.fmi.flexstor"),("gv","text/vnd.graphviz"),("3dml","text/vnd.in3d.3dml"),("spot","text/vnd.in3d.spot"),("jad","text/vnd.sun.j2me.app-descriptor"),("wml","text/vnd.wap.wml"),("wmls","text/vnd.wap.wmlscript"),("s","text/x-asm"),("asm","text/x-asm"),("c","text/x-c"),("cc","text/x-c"),("cxx","text/x-c"),("cpp","text/x-c"),("h","text/x-c"),("hh","text/x-c"),("dic","text/x-c"),("f","text/x-fortran"),("for","text/x-fortran"),("f77","text/x-fortran"),("f90","text/x-fortran"),("java","text/x-java-source"),("nfo","text/x-nfo"),("opml","text/x-opml"),("p","text/x-pascal"),("pas","text/x-pascal"),("etx","text/x-setext"),("sfv","text/x-sfv"),("uu","text/x-uuencode"),("vcs","text/x-vcalendar"),("vcf","text/x-vcard"),("3gp","video/3gpp"),("3g2","video/3gpp2"),("h261","video/h261"),("h263","video/h263"),("h264","video/h264"),("jpgv","video/jpeg"),("jpm","video/jpm"),("jpgm","video/jpm"),("mj2","video/mj2"),("mjp2","video/mj2"),("mp4","video/mp4"),("mp4v","video/mp4"),("mpg4","video/mp4"),("mpeg","video/mpeg"),("mpg","video/mpeg"),("mpe","video/mpeg"),("m1v","video/mpeg"),("m2v","video/mpeg"),("ogv","video/ogg"),("qt","video/quicktime"),("mov","video/quicktime"),("uvh","video/vnd.dece.hd"),("uvvh","video/vnd.dece.hd"),("uvm","video/vnd.dece.mobile"),("uvvm","video/vnd.dece.mobile"),("uvp","video/vnd.dece.pd"),("uvvp","video/vnd.dece.pd"),("uvs","video/vnd.dece.sd"),("uvvs","video/vnd.dece.sd"),("uvv","video/vnd.dece.video"),("uvvv","video/vnd.dece.video"),("dvb","video/vnd.dvb.file"),("fvt","video/vnd.fvt"),("mxu","video/vnd.mpegurl"),("m4u","video/vnd.mpegurl"),("pyv","video/vnd.ms-playready.media.pyv"),("uvu","video/vnd.uvvu.mp4"),("uvvu","video/vnd.uvvu.mp4"),("viv","video/vnd.vivo"),("webm","video/webm"),("f4v","video/x-f4v"),("fli","video/x-fli"),("flv","video/x-flv"),("m4v","video/x-m4v"),("mkv","video/x-matroska"),("mk3d","video/x-matroska"),("mks","video/x-matroska"),("mng","video/x-mng"),("asf","video/x-ms-asf"),("asx","video/x-ms-asf"),("vob","video/x-ms-vob"),("wm","video/x-ms-wm"),("wmv","video/x-ms-wmv"),("wmx","video/x-ms-wmx"),("wvx","video/x-ms-wvx"),("avi","video/x-msvideo"),("movie","video/x-sgi-movie"),("smv","video/x-smv"),("ice","x-conference/x-cooltalk")] diff --git a/src/Happstack/Server/I18N.hs b/src/Happstack/Server/I18N.hs --- a/src/Happstack/Server/I18N.hs +++ b/src/Happstack/Server/I18N.hs @@ -1,9 +1,7 @@ -module Happstack.Server.I18N +module Happstack.Server.I18N ( acceptLanguage , bestLanguage ) where - -import Control.Applicative ((<$>)) import Control.Arrow ((>>>), first, second) import Data.Function (on) diff --git a/src/Happstack/Server/Internal/Clock.hs b/src/Happstack/Server/Internal/Clock.hs --- a/src/Happstack/Server/Internal/Clock.hs +++ b/src/Happstack/Server/Internal/Clock.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS -fno-cse #-} module Happstack.Server.Internal.Clock ( getApproximateTime @@ -6,17 +7,14 @@ , formatHttpDate ) where -import Control.Applicative ((<$>)) import Control.Concurrent import Control.Monad +import qualified Data.ByteString.Char8 as B import Data.IORef import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime) -import Data.Time.Format (formatTime) +import Data.Time.Format (formatTime, defaultTimeLocale) import System.IO.Unsafe -import System.Locale - -import qualified Data.ByteString.Char8 as B data DateCache = DateCache { cachedPOSIXTime :: !(IORef POSIXTime) diff --git a/src/Happstack/Server/Internal/Compression.hs b/src/Happstack/Server/Internal/Compression.hs --- a/src/Happstack/Server/Internal/Compression.hs +++ b/src/Happstack/Server/Internal/Compression.hs @@ -1,15 +1,22 @@ -{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-} +{-# LANGUAGE CPP,NoMonomorphismRestriction, FlexibleContexts #-} -- | Filter for compressing the 'Response' body. module Happstack.Server.Internal.Compression ( compressedResponseFilter + , compressedResponseFilter' , compressWithFilter , gzipFilter , deflateFilter + , identityFilter + , starFilter , encodings + , standardEncodingHandlers ) where import Happstack.Server.SimpleHTTP import Text.ParserCombinators.Parsec import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail (MonadFail) +#endif import Data.Maybe import Data.List import qualified Data.ByteString.Char8 as BS @@ -20,14 +27,51 @@ -- | reads the @Accept-Encoding@ header. Then, if possible -- will compress the response body with methods @gzip@ or @deflate@. -- +-- This function uses 'standardEncodingHandlers'. If you want to +-- provide alternative handers (perhaps to change compression levels), +-- see 'compressedResponseFilter'' +-- -- > main = -- > simpleHTTP nullConf $ -- > do str <- compressedResponseFilter -- > return $ toResponse ("This response compressed using: " ++ str) -compressedResponseFilter:: - (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m) - => m String -- ^ name of the encoding chosen -compressedResponseFilter = do +compressedResponseFilter :: (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m, MonadFail m) => + m String -- ^ name of the encoding chosen +compressedResponseFilter = compressedResponseFilter' standardEncodingHandlers + +-- | reads the @Accept-Encoding@ header. Then, if possible +-- will compress the response body using one of the supplied filters. +-- +-- A filter function takes two arguments. The first is a 'String' with +-- the value to be used as the 'Content-Encoding' header. The second +-- is 'Bool' which indicates if the compression filter is allowed to +-- fallback to @identity@. +-- +-- This is important if the resource being sent using sendfile, since +-- sendfile does not provide a compression option. If @identity@ is +-- allowed, then the file can be sent uncompressed using sendfile. But +-- if @identity@ is not allowed, then the filter will need to return +-- error 406. +-- +-- You should probably always include the @identity@ and @*@ encodings +-- as acceptable. +-- +-- > myFilters :: (FilterMonad Response m) => [(String, String -> Bool -> m ()] +-- > myFilters = [ ("gzip" , gzipFilter) +-- > , ("identity", identityFilter) +-- > , ("*" , starFilter) +-- > ] +-- > +-- > main = +-- > simpleHTTP nullConf $ +-- > do let filters = +-- > str <- compressedResponseFilter' +-- > return $ toResponse ("This response compressed using: " ++ str) +compressedResponseFilter' :: + (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m, MonadFail m) + => [(String, String -> Bool -> m ())] -- ^ compression filter assoc list + -> m String -- ^ name of the encoding chosen +compressedResponseFilter' encodingHandlers = do getHeaderM "Accept-Encoding" >>= (maybe (return "identity") installHandler) @@ -35,7 +79,7 @@ badEncoding = "Encoding returned not in the list of known encodings" installHandler accept = do - let eEncoding = bestEncoding allEncodings $ BS.unpack accept + let eEncoding = bestEncoding (map fst encodingHandlers) $ BS.unpack accept (coding, identityAllowed, action) <- case eEncoding of Left _ -> do setResponseCode 406 @@ -43,8 +87,8 @@ Right encs@(a:_) -> return (a , "identity" `elem` encs - , fromMaybe (fail badEncoding) - (lookup a allEncodingHandlers) + , fromMaybe (\ _ _ -> fail badEncoding) + (lookup a encodingHandlers) ) Right [] -> fail badEncoding action coding identityAllowed @@ -73,13 +117,31 @@ -> m () deflateFilter = compressWithFilter Z.compress +-- | compression filter for the identity encoding (aka, do nothing) +-- +-- see also: 'compressedResponseFilter' +identityFilter :: (FilterMonad Response m) => + String -- ^ encoding to use for Content-Encoding header + -> Bool -- ^ fallback to identity for SendFile (irrelavant for this filter) + -> m () +identityFilter = compressWithFilter id + +-- | compression filter for the * encoding +-- +-- This filter always fails. +starFilter :: (FilterMonad Response m, MonadFail m) => + String -- ^ encoding to use for Content-Encoding header + -> Bool -- ^ fallback to identity for SendFile (irrelavant for this filter) + -> m () +starFilter _ _ = fail "chose * as content encoding" + -- | Ignore the @Accept-Encoding@ header in the 'Request' and attempt to compress the body of the response using the supplied compressor. -- -- We can not compress files being transfered using 'SendFile'. If -- @identity@ is an allowed encoding, then just return the 'Response' --- unmodified. Otherwise we return "406 Not Acceptable". +-- unmodified. Otherwise we return @406 Not Acceptable@. -- --- see also: 'gzipFilter' and 'defaultFilter' +-- see also: 'gzipFilter', 'deflateFilter', 'identityFilter', 'starFilter', 'compressedResponseFilter'' compressWithFilter :: (FilterMonad Response m) => (L.ByteString -> L.ByteString) -- ^ function to compress the body -> String -- ^ encoding to use for Content-Encoding header @@ -88,7 +150,9 @@ compressWithFilter compressor encoding identityAllowed = composeFilter $ \r -> case r of - Response{} -> setHeader "Content-Encoding" encoding $ r {rsBody = compressor $ rsBody r} + Response{} -> setHeader "Content-Encoding" encoding $ + setHeader "Vary" "Accept-Encoding" $ + r {rsBody = compressor $ rsBody r} _ | identityAllowed -> r | otherwise -> (toResponse "") { rsCode = 406 } @@ -135,11 +199,18 @@ | otherwise = compare (m0 mI) (m0 mJ) -allEncodingHandlers:: (FilterMonad Response m) => [(String, String -> Bool -> m ())] -allEncodingHandlers = zip allEncodings handlers +-- | an assoc list of encodings and their corresponding compression +-- functions. +-- +-- e.g. +-- +-- > [("gzip", gzipFilter), ("identity", identityFilter), ("*",starFilter)] +standardEncodingHandlers :: (FilterMonad Response m, MonadFail m) => + [(String, String -> Bool -> m ())] +standardEncodingHandlers = zip standardEncodings handlers -allEncodings :: [String] -allEncodings = +standardEncodings :: [String] +standardEncodings = ["gzip" ,"x-gzip" -- ,"compress" -- as far as I can tell there is no haskell library that supports this @@ -149,15 +220,15 @@ ,"*" ] -handlers::(FilterMonad Response m) => [String -> Bool -> m ()] +handlers::(FilterMonad Response m, MonadFail m) => [String -> Bool -> m ()] handlers = - [gzipFilter - ,gzipFilter + [ gzipFilter + , gzipFilter -- ,compressFilter -- ,compressFilter - ,deflateFilter - , \encoding _ -> setHeaderM "Accept-Encoding" encoding - ,const $ fail "chose * as content encoding" + , deflateFilter + , identityFilter + , starFilter ] -- | a parser for the Accept-Encoding header 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 @@ -1,9 +1,10 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} -- http://tools.ietf.org/html/rfc2109 module Happstack.Server.Internal.Cookie ( Cookie(..) , CookieLife(..) + , SameSite(..) , calcLife , mkCookie , mkCookieHeader @@ -17,17 +18,21 @@ where import Control.Monad +import Control.Monad.Fail (MonadFail) import qualified Data.ByteString.Char8 as C import Data.Char (chr, toLower) -import Data.Data (Data, Typeable) +import Data.Data (Data) import Data.List ((\\), intersperse) import Data.Time.Clock (UTCTime, addUTCTime, diffUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Time.Format (formatTime) +import Data.Time.Format (formatTime, defaultTimeLocale) import Happstack.Server.Internal.Clock (getApproximateUTCTime) +import Network.URI (escapeURIString) import Text.ParserCombinators.Parsec hiding (token) -import System.Locale (defaultTimeLocale) + + + -- | a type for HTTP cookies. Usually created using 'mkCookie'. data Cookie = Cookie { cookieVersion :: String @@ -37,7 +42,9 @@ , cookieValue :: String , secure :: Bool , httpOnly :: Bool - } deriving(Show,Eq,Read,Typeable,Data) + , sameSite :: SameSite + , partitioned :: Bool + } deriving (Show, Eq, Read, Data) -- | Specify the lifetime of a cookie. -- @@ -51,8 +58,33 @@ | MaxAge Int -- ^ life time of cookie in seconds | Expires UTCTime -- ^ cookie expiration date | Expired -- ^ cookie already expired - deriving (Eq, Ord, Read, Show, Typeable) + deriving (Eq, Ord, Read, Show) +-- | Options for specifying third party cookie behaviour. +-- +-- Note that most or all web clients require the cookie to be secure if "none" is +-- specified. +data SameSite + = SameSiteLax + -- ^ The cookie is sent in first party contexts as well as linked requests initiated + -- from other contexts. + | SameSiteStrict + -- ^ The cookie is sent in first party contexts only. + | SameSiteNone + -- ^ The cookie is sent in first as well as third party contexts if the cookie is + -- secure. + | SameSiteNoValue + -- ^ The default; used if you do not wish a SameSite attribute present at all. + deriving (Eq, Ord, Data, Show, Read) + +displaySameSite :: SameSite -> String +displaySameSite ss = + case ss of + SameSiteLax -> "SameSite=Lax" + SameSiteStrict -> "SameSite=Strict" + SameSiteNone -> "SameSite=None" + SameSiteNoValue -> "" + -- convert 'CookieLife' to the argument needed for calling 'mkCookieHeader' calcLife :: CookieLife -> IO (Maybe (Int, UTCTime)) calcLife Session = return Nothing @@ -67,13 +99,14 @@ -- | Creates a cookie with a default version of 1, empty domain, a --- path of "/", secure == False and httpOnly == False +-- path of "/", secure == False, httpOnly == False and +-- sameSite == SameSiteNoValue and partitioned = False -- -- see also: 'addCookie' mkCookie :: String -- ^ cookie name -> String -- ^ cookie value -> Cookie -mkCookie key val = Cookie "1" "/" "" key val False False +mkCookie key val = Cookie "1" "/" "" key val False False SameSiteNoValue False -- | Set a Cookie in the Result. -- The values are escaped as per RFC 2109, but some browsers may @@ -90,21 +123,29 @@ -- the first argument to this function. mkCookieHeader :: Maybe (Int, UTCTime) -> Cookie -> String mkCookieHeader mLife cookie = - let l = [("Domain=", cookieDomain cookie) - ,("Max-Age=", maybe "" (show . max 0 . fst) mLife) - ,("expires=", maybe "" (formatTime defaultTimeLocale "%a, %d-%b-%Y %X GMT" . snd) mLife) - ,("Path=", cookiePath cookie) - ,("Version=", s cookieVersion)] - s f | f cookie == "" = "" - s f = '\"' : concatMap e (f cookie) ++ "\"" - e c | fctl c || c == '"' = ['\\',c] - | otherwise = [c] - in concat $ intersperse ";" ((cookieName cookie++"="++s cookieValue):[ (k++v) | (k,v) <- l, "" /= v ] ++ - (if secure cookie then ["Secure"] else []) ++ - (if httpOnly cookie then ["HttpOnly"] else [])) - -fctl :: Char -> Bool -fctl ch = ch == chr 127 || ch <= chr 31 + let + l = + [ (,) "Domain=" (cookieDomain cookie) + , (,) "Max-Age=" (maybe "" (show . max 0 . fst) mLife) + , (,) "expires=" (maybe "" (formatTime' . snd) mLife) + , (,) "Path=" (cookiePath cookie) + , (,) "Version=" (s cookieVersion) + ] + formatTime' = + formatTime defaultTimeLocale "%a, %d-%b-%Y %X GMT" + encode = + escapeURIString + (\c -> c `elem` (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~")) + s f | f cookie == "" = "" + | otherwise = '\"' : (encode $ f cookie) ++ "\"" + in + concat $ intersperse ";" $ + (cookieName cookie++"="++s cookieValue):[ (k++v) | (k,v) <- l, "" /= v ] + ++ (if secure cookie then ["Secure"] else []) + ++ (if httpOnly cookie then ["HttpOnly"] else []) + ++ (if sameSite cookie /= SameSiteNoValue + then [displaySameSite . sameSite $ cookie] else []) + ++ (if partitioned cookie then ["Partitioned"] else []) -- | Not an supported api. Takes a cookie header and returns -- either a String error message or an array of parsed cookies @@ -128,7 +169,7 @@ val<-value path<-option "" $ try (cookieSep >> cookie_path) domain<-option "" $ try (cookieSep >> cookie_domain) - return $ Cookie ver path domain (low name) val False False + return $ Cookie ver path domain (low name) val False False SameSiteNoValue False cookie_version = cookie_special "$Version" cookie_path = cookie_special "$Path" cookie_domain = cookie_special "$Domain" @@ -164,13 +205,13 @@ -- | Get all cookies from the HTTP request. The cookies are ordered per RFC from -- the most specific to the least specific. Multiple cookies with the same -- name are allowed to exist. -getCookies :: Monad m => C.ByteString -> m [Cookie] +getCookies :: MonadFail m => C.ByteString -> m [Cookie] getCookies h = getCookies' h >>= either (fail. ("Cookie parsing failed!"++)) return -- | Get the most specific cookie with the given name. Fails if there is no such -- cookie or if the browser did not escape cookies in a proper fashion. -- Browser support for escaping cookies properly is very diverse. -getCookie :: Monad m => String -> C.ByteString -> m Cookie +getCookie :: MonadFail m => String -> C.ByteString -> m Cookie getCookie s h = getCookie' s h >>= either (const $ fail ("getCookie: " ++ show s)) return getCookies' :: Monad m => C.ByteString -> m (Either String [Cookie]) @@ -183,9 +224,8 @@ return $ do -- Either cooks <- cs case filter (\x->(==) (low s) (cookieName x) ) cooks of - [] -> fail "No cookie found" + [] -> Left "No cookie found" f -> return $ head f low :: String -> String low = map toLower - 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 @@ -1,13 +1,14 @@ -{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables, TupleSections #-} module Happstack.Server.Internal.Handler ( request - , parseResponse + , parseResponse , putRequest ) where import qualified Paths_happstack_server as Paths import qualified Data.Version as DV +import Control.Applicative (pure) import Control.Concurrent (newMVar, newEmptyMVar, tryTakeMVar) import Control.Exception.Extensible as E import Control.Monad @@ -32,6 +33,7 @@ import Happstack.Server.SURI(SURI(..),path,query) import Happstack.Server.SURI.ParseURI import Happstack.Server.Internal.TimeoutIO (TimeoutIO(..)) +import Happstack.Server.Internal.Monads (failResponse) import qualified Happstack.Server.Internal.TimeoutManager as TM import Numeric import System.Directory (removeFile) @@ -55,17 +57,19 @@ rloop timeoutIO mlog host handler inputStr | L.null inputStr = return () | otherwise - = join $ + = (join $ do let parseRequest = do (topStr, restStr) <- required "failed to separate request" $ splitAtEmptyLine inputStr (rql, headerStr) <- required "failed to separate headers/body" $ splitAtCRLF topStr let (m,u,v) = requestLine rql - headers' <- parseHeaders "host" (L.unpack headerStr) + headers' <- case parseHeaders "host" (L.unpack headerStr) of + Nothing -> Left "failed to parse host header" + Just x -> Right x let headers = mkHeaders headers' let contentLen = fromMaybe 0 $ fmap fst (P.readInt =<< getHeaderUnsafe contentlengthC headers) (body, nextRequest) <- case () of - () | contentLen < 0 -> fail "negative content-length" + () | contentLen < 0 -> Left "negative content-length" | isJust $ getHeaderBS transferEncodingC headers -> return $ consumeChunks restStr | otherwise -> return (L.splitAt (fromIntegral contentLen) restStr) @@ -75,7 +79,7 @@ case parseRequest of Left err -> error $ "failed to parse HTTP request: " ++ err Right (m, u, cookies, v, headers, body, nextRequest) - -> return $ + -> pure $ do bodyRef <- newMVar (Body body) bodyInputRef <- newEmptyMVar let req = Request (toSecure timeoutIO) m (pathEls (path u)) (path u) (query u) @@ -83,7 +87,10 @@ let ioseq act = act >>= \x -> x `seq` return x - res <- ioseq (handler req) `E.catch` \(e::E.SomeException) -> return $ result 500 $ "Server error: " ++ show e + (res, handlerKilled) <- ((, False) `liftM` ioseq (handler req)) + `E.catches` [ Handler $ \(e::EscapeHTTP) -> throwIO e -- need to handle this higher up + , Handler $ \(e::E.SomeException) -> pure (failResponse (show e), fromException e == Just ThreadKilled) + ] case mlog of Nothing -> return () @@ -102,11 +109,18 @@ putAugmentedResult timeoutIO req res -- clean up tmp files cleanupTempFiles req - when (continueHTTP req res) $ rloop timeoutIO mlog host handler nextRequest + -- do not continue if handler was killed + when (not handlerKilled && continueHTTP req res) $ + rloop timeoutIO mlog host handler nextRequest) `E.catch` (escapeHttpHandler timeoutIO) +escapeHttpHandler :: TimeoutIO + -> EscapeHTTP + -> IO () +escapeHttpHandler tio (EscapeHTTP f) = f tio + -- NOTE: if someone took the inputs and never put them back, then they are responsible for the cleanup cleanupTempFiles :: Request -> IO () -cleanupTempFiles req = +cleanupTempFiles req = do mInputs <- tryTakeMVar (rqInputsBody req) case mInputs of Nothing -> return () @@ -127,7 +141,9 @@ (rsl,headerStr) <- required "failed to separate headers/body" $ splitAtCRLF topStr let (_,code) = responseLine rsl - headers' <- parseHeaders "host" (L.unpack headerStr) + headers' <- case parseHeaders "host" (L.unpack headerStr) of + Nothing -> Left "failed to parse host header" + Just x -> Right x let headers = mkHeaders headers' let mbCL = fmap fst (B.readInt =<< getHeader "content-length" headers) (body,_) <- @@ -190,15 +206,17 @@ method :: B.ByteString -> Method method r = fj $ lookup r mtable where fj (Just x) = x - fj Nothing = error "invalid request method" - mtable = [(P.pack "GET", GET), - (P.pack "HEAD", HEAD), - (P.pack "POST", POST), - (P.pack "PUT", PUT), - (P.pack "DELETE", DELETE), - (P.pack "TRACE", TRACE), - (P.pack "OPTIONS", OPTIONS), - (P.pack "CONNECT", CONNECT)] + fj Nothing = EXTENSION r + mtable = [ (P.pack "GET", GET) + , (P.pack "HEAD", HEAD) + , (P.pack "POST", POST) + , (P.pack "PUT", PUT) + , (P.pack "DELETE", DELETE) + , (P.pack "TRACE", TRACE) + , (P.pack "OPTIONS", OPTIONS) + , (P.pack "CONNECT", CONNECT) + , (P.pack "PATCH", PATCH) + ] -- Result side 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 @@ -1,24 +1,20 @@ {-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} module Happstack.Server.Internal.Listen(listen, listen',listenOn,listenOnIPv4) where +import Data.Maybe (isNothing) import Happstack.Server.Internal.Types (Conf(..), Request, Response) import Happstack.Server.Internal.Handler (request) import Happstack.Server.Internal.Socket (acceptLite) -import Happstack.Server.Internal.TimeoutManager (cancel, initialize, register) +import Happstack.Server.Internal.TimeoutManager (cancel, initialize, register, forceTimeoutAll) import Happstack.Server.Internal.TimeoutSocket as TS import qualified Control.Concurrent.Thread.Group as TG import Control.Exception.Extensible as E import Control.Concurrent (forkIO, killThread, myThreadId) import Control.Monad -import Network.BSD (getProtocolNumber) -import Network (sClose, Socket) -import Network.Socket as Socket (SocketOption(KeepAlive), setSocketOption, - socket, Family(..), SockAddr, - SocketOption(..), SockAddr(..), - iNADDR_ANY, maxListenQueue, SocketType(..), - bindSocket) -import qualified Network.Socket as Socket (listen, inet_addr) +import qualified Data.Maybe as Maybe +import qualified Network.Socket as Socket import System.IO.Error (isFullError) +import Foreign.C (CInt) {- #ifndef mingw32_HOST_OS -} @@ -30,6 +26,12 @@ log':: Priority -> String -> IO () log' = logM "Happstack.Server.HTTP.Listen" +-- Meant to be TCP in practise. +-- See https://www.gnu.org/software/libc/manual/html_node/Creating-a-Socket.html +-- which says "zero is usually right". It could theoretically be SCTP, but it +-- would be a bizarre system that defaults to SCTP over TCP. +proto :: CInt +proto = Socket.defaultProtocol {- Network.listenOn binds randomly to IPv4 or IPv6 or both, @@ -37,45 +39,56 @@ Lets make it use IPv4 only for now. -} -listenOn :: Int -> IO Socket +listenOn :: Int -> IO Socket.Socket listenOn portm = do - proto <- getProtocolNumber "tcp" E.bracketOnError - (socket AF_INET Stream proto) - (sClose) + (Socket.socket Socket.AF_INET Socket.Stream proto) + (Socket.close) (\sock -> do - setSocketOption sock ReuseAddr 1 - bindSocket sock (SockAddrInet (fromIntegral portm) iNADDR_ANY) - Socket.listen sock (max 1024 maxListenQueue) + Socket.setSocketOption sock Socket.ReuseAddr 1 + Socket.bind sock (Socket.SockAddrInet (fromIntegral portm) iNADDR_ANY) + Socket.listen sock (max 1024 Socket.maxListenQueue) return sock ) listenOnIPv4 :: String -- ^ IP address to listen on (must be an IP address not a host name) -> Int -- ^ port number to listen on - -> IO Socket + -> IO Socket.Socket listenOnIPv4 ip portm = do - proto <- getProtocolNumber "tcp" - hostAddr <- Socket.inet_addr ip + hostAddr <- inet_addr ip E.bracketOnError - (socket AF_INET Stream proto) - (sClose) + (Socket.socket Socket.AF_INET Socket.Stream proto) + (Socket.close) (\sock -> do - setSocketOption sock ReuseAddr 1 - bindSocket sock (SockAddrInet (fromIntegral portm) hostAddr) - Socket.listen sock (max 1024 maxListenQueue) + Socket.setSocketOption sock Socket.ReuseAddr 1 + Socket.bind sock (Socket.SockAddrInet (fromIntegral portm) hostAddr) + Socket.listen sock (max 1024 Socket.maxListenQueue) return sock ) +inet_addr :: String -> IO Socket.HostAddress +inet_addr ip = do + addrInfos <- Socket.getAddrInfo (Just Socket.defaultHints) (Just ip) Nothing + let getHostAddress addrInfo = case Socket.addrAddress addrInfo of + Socket.SockAddrInet _ hostAddress -> Just hostAddress + _ -> Nothing + maybe (fail "inet_addr: no HostAddress") pure + . Maybe.listToMaybe + $ Maybe.mapMaybe getHostAddress addrInfos + +iNADDR_ANY :: Socket.HostAddress +iNADDR_ANY = 0 + -- | Bind and listen port listen :: Conf -> (Request -> IO Response) -> IO () listen conf hand = do let port' = port conf - socketm <- listenOn port' - setSocketOption socketm KeepAlive 1 - listen' socketm conf hand + lsocket <- listenOn port' + Socket.setSocketOption lsocket Socket.KeepAlive 1 + listen' lsocket conf hand -- | Use a previously bind port and listen -listen' :: Socket -> Conf -> (Request -> IO Response) -> IO () +listen' :: Socket.Socket -> Conf -> (Request -> IO Response) -> IO () listen' s conf hand = do {- #ifndef mingw32_HOST_OS @@ -99,14 +112,14 @@ request timeoutIO (logAccess conf) (hn,fromIntegral p) hand `E.catch` eh -- remove thread from timeout table cancel thandle - sClose sock + Socket.close sock loop = forever $ do w <- acceptLite s fork $ work w pe e = log' ERROR ("ERROR in http accept thread: " ++ show e) infi :: IO () infi = loop `catchSome` pe >> infi - infi `finally` (sClose s) + infi `finally` (Socket.close s >> when (isNothing $ threadGroup conf) (forceTimeoutAll tm)) {-- #ifndef mingw32_HOST_OS diff --git a/src/Happstack/Server/Internal/LogFormat.hs b/src/Happstack/Server/Internal/LogFormat.hs --- a/src/Happstack/Server/Internal/LogFormat.hs +++ b/src/Happstack/Server/Internal/LogFormat.hs @@ -1,10 +1,10 @@ +{-# LANGUAGE CPP #-} module Happstack.Server.Internal.LogFormat ( formatTimeCombined , formatRequestCombined ) where -import System.Locale (defaultTimeLocale) -import Data.Time.Format (FormatTime(..), formatTime) +import Data.Time.Format (FormatTime(..), formatTime, defaultTimeLocale) -- | Format the time as describe in the Apache combined log format. -- http://httpd.apache.org/docs/2.2/logs.html#combined 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 @@ -43,7 +43,7 @@ } bodyInput :: (MonadIO m) => BodyPolicy -> Request -> m ([(String, Input)], Maybe String) -bodyInput _ req | ((rqMethod req /= POST) && (rqMethod req /= PUT)) || (not (isDecodable ctype)) = +bodyInput _ req | (not (canHaveBody (rqMethod req))) || (not (isDecodable ctype)) = do _ <- liftIO $ tryPutMVar (rqInputsBody req) [] return ([], Nothing) where @@ -83,7 +83,18 @@ (name,val)=split (=='=') pairString rest=if null qString' then [] else formDecode qString' --- FIXME: no size limits on application/x-www-form-urlencoded yet +-- | Decodes application\/x-www-form-urlencoded inputs. +-- TODO: should any of the [] be error conditions? +formDecodeBS :: L.ByteString -> [(String, Input)] +formDecodeBS qString | L.null qString = [] +formDecodeBS qString = + if L.null pairString + then rest -- skip in case of consecutive ampersands "...&&..." + else (SURI.unEscapeQS (L.unpack name), simpleInput $ SURI.unEscapeQS (L.unpack $ L.drop 1 val)) : rest + where (pairString,qString') = L.break (== '&') qString + (name,val) = L.break (== '=') pairString + rest = formDecodeBS (L.drop 1 qString') + -- FIXME: is usend L.unpack really the right thing to do decodeBody :: BodyPolicy -> Maybe ContentType @@ -92,14 +103,20 @@ decodeBody bp ctype inp = case ctype of Just (ContentType "application" "x-www-form-urlencoded" _) -> - return (formDecode (L.unpack (L.take (maxRAM bp) inp)), Nothing) + return decodedUrlEncodedForm Just (ContentType "multipart" "form-data" ps) -> multipartDecode ((inputWorker bp) (maxDisk bp) (maxRAM bp) (maxHeader bp)) ps inp Just ct -> return ([], Just $ "decodeBody: unsupported content-type: " ++ show ct) -- unknown content-type, the user will have to -- deal with it by looking at the raw content -- No content-type given, assume x-www-form-urlencoded - Nothing -> return (formDecode (L.unpack (L.take (maxRAM bp) inp)), Nothing) + Nothing -> return decodedUrlEncodedForm + where + (upToMaxRAM,overMaxRAM) = L.splitAt (maxRAM bp) inp + decodedUrlEncodedForm = (formDecodeBS upToMaxRAM, + if L.null overMaxRAM + then Nothing + else Just ("x-www-form-urlencoded content longer than BodyPolicy.maxRAM=" ++ show (maxRAM bp) ++ " bytes")) -- | Decodes multipart\/form-data input. multipartDecode :: InputWorker diff --git a/src/Happstack/Server/Internal/Monads.hs b/src/Happstack/Server/Internal/Monads.hs --- a/src/Happstack/Server/Internal/Monads.hs +++ b/src/Happstack/Server/Internal/Monads.hs @@ -1,24 +1,37 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE CPP, 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 import Control.Applicative (Applicative, pure, (<*>), Alternative(empty,(<|>))) +import Control.Concurrent (newMVar) +import Control.Exception (throwIO) + 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.Catch ( MonadCatch(..), MonadThrow(..) ) +#if !MIN_VERSION_transformers(0,6,0) +import Control.Monad.Trans.Error ( ErrorT, Error, mapErrorT ) +#endif +import Control.Monad.Except ( MonadError, throwError + , catchError ) +#if MIN_VERSION_base(4,9,0) +import Control.Monad.Fail (MonadFail) +import qualified Control.Monad.Fail as Fail +#endif import Control.Monad.Reader ( ReaderT(ReaderT), runReaderT , MonadReader, ask, local, mapReaderT ) -import Control.Monad.RWS ( RWST, mapRWST - ) +import qualified Control.Monad.RWS.Lazy as Lazy ( RWST, mapRWST ) +import qualified Control.Monad.RWS.Strict as Strict ( RWST, mapRWST ) -import Control.Monad.State (MonadState, StateT, get, put, mapStateT) +import Control.Monad.Trans.Except ( ExceptT(ExceptT), mapExceptT, runExceptT ) +import Control.Monad.State.Class ( MonadState, get, put ) +import qualified Control.Monad.State.Lazy as Lazy ( StateT, mapStateT ) +import qualified Control.Monad.State.Strict as Strict ( StateT, mapStateT ) import Control.Monad.Trans ( MonadTrans, lift , MonadIO, liftIO ) @@ -26,22 +39,30 @@ , MonadBaseControl(..) , ComposeSt, defaultLiftBaseWith, defaultRestoreM ) -import Control.Monad.Writer ( WriterT(WriterT), runWriterT - , MonadWriter, tell, pass - , listens, mapWriterT - ) -import qualified Control.Monad.Writer as Writer (listen) -- So that we can disambiguate 'Listen.listen' +import Control.Monad.Writer.Class ( MonadWriter, tell, pass, listens ) +import qualified Control.Monad.Writer.Lazy as Lazy ( WriterT(WriterT), runWriterT, mapWriterT ) +import qualified Control.Monad.Writer.Strict as Strict ( WriterT, mapWriterT ) +import qualified Control.Monad.Writer.Class as Writer ( listen ) import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT) +import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.Lazy.UTF8 as LU (fromString) import Data.Char (ord) import Data.List (inits, isPrefixOf, stripPrefix, tails) +import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(mempty, mappend), Dual(..), Endo(..)) +import qualified Data.Semigroup as SG import qualified Paths_happstack_server as Cabal import qualified Data.Version as DV import Debug.Trace (trace) -import Happstack.Server.Types (Request, Response, resultBS, setHeader) +import Happstack.Server.Internal.Cookie (Cookie) +import Happstack.Server.Internal.RFC822Headers (parseContentType) +import Happstack.Server.Internal.Types (EscapeHTTP(..), canHaveBody) +import Happstack.Server.Internal.TimeoutIO (TimeoutIO) +import Happstack.Server.Types +import Prelude (Bool(..), Either(..), Eq(..), Functor(..), IO, Monad(..), Char, Maybe(..), String, Show(..), ($), (.), (>), (++), (&&), (||), (=<<), const, concatMap, flip, id, otherwise, zip) + -- | An alias for 'WebT' when using 'IO'. type Web a = WebT IO a @@ -55,8 +76,18 @@ -- -- see also: 'simpleHTTP', 'ServerMonad', 'FilterMonad', 'WebMonad', and 'HasRqData' newtype ServerPartT m a = ServerPartT { unServerPartT :: ReaderT Request (WebT m) a } +#if MIN_VERSION_base(4,9,0) + deriving (Monad, MonadFail, MonadPlus, Functor) +#else deriving (Monad, MonadPlus, Functor) +#endif +instance MonadCatch m => MonadCatch (ServerPartT m) where + catch action handle = ServerPartT $ catch (unServerPartT action) (unServerPartT . handle) + +instance MonadThrow m => MonadThrow (ServerPartT m) where + throwM = ServerPartT . throwM + instance MonadBase b m => MonadBase b (ServerPartT m) where liftBase = lift . liftBase @@ -65,16 +96,16 @@ {-# INLINE liftIO #-} instance MonadTransControl ServerPartT where - newtype StT ServerPartT a = StSP {unStSP :: StT WebT (StT (ReaderT Request) a)} + type StT ServerPartT a = StT WebT (StT (ReaderT Request) a) liftWith f = ServerPartT $ liftWith $ \runReader -> liftWith $ \runWeb -> - f $ liftM StSP . runWeb . runReader . unServerPartT - restoreT = ServerPartT . restoreT . restoreT . liftM unStSP + f $ runWeb . runReader . unServerPartT + restoreT = ServerPartT . restoreT . restoreT instance MonadBaseControl b m => MonadBaseControl b (ServerPartT m) where - newtype StM (ServerPartT m) a = StMSP {unStMSP :: ComposeSt ServerPartT m a} - liftBaseWith = defaultLiftBaseWith StMSP - restoreM = defaultRestoreM unStMSP + type StM (ServerPartT m) a = ComposeSt ServerPartT m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM -- | Particularly useful when combined with 'runWebT' to produce -- a @m ('Maybe' 'Response')@ from a 'Request'. @@ -150,9 +181,12 @@ instance MonadTrans (ServerPartT) where lift m = withRequest (\_ -> lift m) -instance (Monad m) => Monoid (ServerPartT m a) where +instance (Monad m, MonadPlus m) => SG.Semigroup (ServerPartT m a) where + (<>) = mplus + +instance (Monad m, MonadPlus m) => Monoid (ServerPartT m a) where mempty = mzero - mappend = mplus + mappend = (SG.<>) instance (Monad m, Functor m) => Applicative (ServerPartT m) where pure = return @@ -200,10 +234,37 @@ askRq = ServerPartT $ ask localRq f m = ServerPartT $ local f (unServerPartT m) -instance (Error e, ServerMonad m) => ServerMonad (ErrorT e m) where - askRq = lift askRq - localRq f = mapErrorT $ localRq f +-- | Implementation of 'askRqEnv' for arbitrary 'ServerMonad'. +smAskRqEnv :: (ServerMonad m, MonadIO m) => m ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)]) +smAskRqEnv = do + rq <- askRq + mbi <- liftIO $ if (canHaveBody (rqMethod rq)) && (isDecodable (ctype rq)) + then readInputsBody rq + else return (Just []) + return (rqInputsQuery rq, mbi, rqCookies rq) + where + ctype :: Request -> Maybe ContentType + ctype req = parseContentType . P.unpack =<< getHeader "content-type" req + 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 _) = False + +-- | Implementation of 'localRqEnv' for arbitrary 'ServerMonad'. +smLocalRqEnv :: (ServerMonad m, MonadIO m) => (([(String, Input)], Maybe [(String, Input)], [(String, Cookie)]) -> ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)])) -> m b -> m b +smLocalRqEnv f m = do + rq <- askRq + b <- liftIO $ readInputsBody rq + let (q', b', c') = f (rqInputsQuery rq, b, rqCookies rq) + bv <- liftIO $ newMVar (fromMaybe [] b') + let rq' = rq { rqInputsQuery = q' + , rqInputsBody = bv + , rqCookies = c' + } + localRq (const rq') m + ------------------------------- -- HERE BEGINS WebT definitions @@ -221,12 +282,14 @@ data SetAppend a = Set a | Append a deriving (Eq, Show) -instance Monoid a => Monoid (SetAppend a) where - mempty = Append mempty +instance Monoid a => SG.Semigroup (SetAppend a) where + Set x <> Append y = Set (x `mappend` y) + Append x <> Append y = Append (x `mappend` y) + _ <> Set y = Set y - Set x `mappend` Append y = Set (x `mappend` y) - Append x `mappend` Append y = Append (x `mappend` y) - _ `mappend` Set y = Set y +instance Monoid a => Monoid (SetAppend a) where + mempty = Append mempty + mappend = (SG.<>) -- | Extract the value from a 'SetAppend'. -- Note that a 'SetAppend' is actually a @CoPointed@ from: @@ -251,9 +314,15 @@ filterFun :: (a -> a) -> FilterFun a filterFun = Set . Dual . Endo -newtype FilterT a m b = FilterT { unFilterT :: WriterT (FilterFun a) m b } +newtype FilterT a m b = FilterT { unFilterT :: Lazy.WriterT (FilterFun a) m b } deriving (Functor, Applicative, Monad, MonadTrans) +instance MonadCatch m => MonadCatch (FilterT a m) where + catch action handle = FilterT $ catch (unFilterT action) (unFilterT . handle) + +instance MonadThrow m => MonadThrow (FilterT a m) where + throwM = FilterT . throwM + instance MonadBase b m => MonadBase b (FilterT a m) where liftBase = lift . liftBase @@ -262,14 +331,14 @@ {-# INLINE liftIO #-} instance MonadTransControl (FilterT a) where - newtype StT (FilterT a) b = StFilter {unStFilter :: StT (WriterT (FilterFun a)) b} - liftWith f = FilterT $ liftWith $ \run -> f $ liftM StFilter . run . unFilterT - restoreT = FilterT . restoreT . liftM unStFilter + type StT (FilterT a) b = StT (Lazy.WriterT (FilterFun a)) b + liftWith f = FilterT $ liftWith $ \run -> f $ run . unFilterT + restoreT = FilterT . restoreT instance MonadBaseControl b m => MonadBaseControl b (FilterT a m) where - newtype StM (FilterT a m) c = StMFilter {unStMFilter :: ComposeSt (FilterT a) m c} - liftBaseWith = defaultLiftBaseWith StMFilter - restoreM = defaultRestoreM unStMFilter + type StM (FilterT a m) c = ComposeSt (FilterT a) m c + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM -- | A set of functions for manipulating filters. -- @@ -304,9 +373,15 @@ getFilter = FilterT . listens unFilterFun . unFilterT -- | The basic 'Response' building object. -newtype WebT m a = WebT { unWebT :: ErrorT Response (FilterT (Response) (MaybeT m)) a } +newtype WebT m a = WebT { unWebT :: ExceptT Response (FilterT (Response) (MaybeT m)) a } deriving (Functor) +instance MonadCatch m => MonadCatch (WebT m) where + catch action handle = WebT $ catch (unWebT action) (unWebT . handle) + +instance MonadThrow m => MonadThrow (WebT m) where + throwM = WebT . throwM + instance MonadBase b m => MonadBase b (WebT m) where liftBase = lift . liftBase @@ -315,21 +390,21 @@ {-# INLINE liftIO #-} instance MonadTransControl WebT where - newtype StT WebT a = StWeb {unStWeb :: StT MaybeT - (StT (FilterT Response) - (StT (ErrorT Response) a))} + type StT WebT a = StT MaybeT + (StT (FilterT Response) + (StT (ExceptT Response) a)) liftWith f = WebT $ liftWith $ \runError -> liftWith $ \runFilter -> liftWith $ \runMaybe -> - f $ liftM StWeb . runMaybe . - runFilter . - runError . unWebT - restoreT = WebT . restoreT . restoreT . restoreT . liftM unStWeb + f $ runMaybe . + runFilter . + runExceptT . unWebT + restoreT = WebT . restoreT . restoreT . restoreT instance MonadBaseControl b m => MonadBaseControl b (WebT m) where - newtype StM (WebT m) a = StMWeb {unStMWeb :: ComposeSt WebT m a} - liftBaseWith = defaultLiftBaseWith StMWeb - restoreM = defaultRestoreM unStMWeb + type StM (WebT m) a = ComposeSt WebT m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM -- | 'UnWebT' is almost exclusively used with 'mapServerPartT'. If you -- are not using 'mapServerPartT' then you do not need to wrap your @@ -389,8 +464,13 @@ {-# INLINE (>>=) #-} return a = WebT $ return a {-# INLINE return #-} - fail s = outputTraceMessage s (mkFailMessage s) +#if MIN_VERSION_base(4,9,0) +instance MonadFail m => MonadFail (WebT m) where +#endif + + fail s = lift (Fail.fail s) + -- | 'WebMonad' provides a means to end the current computation -- and return a 'Response' immediately. This provides an -- alternate escape route. In particular it has a monadic value @@ -425,7 +505,7 @@ instance MonadTrans WebT where lift = WebT . lift . lift . lift -instance (Monad m) => MonadPlus (WebT m) where +instance (Monad m, MonadPlus m) => MonadPlus (WebT m) where -- | Aborts a computation. -- -- This is primarily useful because 'msum' will take an array of @@ -433,29 +513,32 @@ -- is exactly the semantics expected from objects that take lists -- of 'ServerPartT'. mzero = WebT $ lift $ lift $ mzero - mplus x y = WebT $ ErrorT $ FilterT $ (lower x) `mplus` (lower y) - where lower = (unFilterT . runErrorT . unWebT) + mplus x y = WebT $ ExceptT $ FilterT $ (lower x) `mplus` (lower y) + where lower = (unFilterT . runExceptT . unWebT) instance (Monad m) => FilterMonad Response (WebT m) where setFilter f = WebT $ lift $ setFilter $ f composeFilter f = WebT . lift . composeFilter $ f - getFilter m = WebT $ ErrorT $ liftM lft $ getFilter (runErrorT $ unWebT m) + getFilter m = WebT $ ExceptT $ liftM lft $ getFilter (runExceptT $ unWebT m) where lft (Left r, _) = Left r lft (Right a, f) = Right (a, f) -instance (Monad m) => Monoid (WebT m a) where - mempty = mzero - mappend = mplus +instance (Monad m, MonadPlus m) => SG.Semigroup (WebT m a) where + (<>) = mplus +instance (Monad m, MonadPlus m) => Monoid (WebT m a) where + mempty = mzero + mappend = (SG.<>) + -- | For when you really need to unpack a 'WebT' entirely (and not -- just unwrap the first layer with 'unWebT'). ununWebT :: WebT m a -> UnWebT m a -ununWebT = runMaybeT . runWriterT . unFilterT . runErrorT . unWebT +ununWebT = runMaybeT . Lazy.runWriterT . unFilterT . runExceptT . unWebT -- | For wrapping a 'WebT' back up. @'mkWebT' . 'ununWebT' = 'id'@ mkWebT :: UnWebT m a -> WebT m a -mkWebT = WebT . ErrorT . FilterT . WriterT . MaybeT +mkWebT = WebT . ExceptT . FilterT . Lazy.WriterT . MaybeT -- | See 'mapServerPartT' for a discussion of this function. mapWebT :: (UnWebT m a -> UnWebT n b) @@ -500,7 +583,7 @@ liftWebT (Just (Right x,f)) = pass (return x)>>= (\a -> return $ Just (Right a,f)) -- | Deprecated: use 'msum'. -multi :: Monad m => [ServerPartT m a] -> ServerPartT m a +multi :: (Monad m, MonadPlus m) => [ServerPartT m a] -> ServerPartT m a multi = msum {-# DEPRECATED multi "Use msum instead" #-} @@ -531,10 +614,13 @@ mkFailMessage :: (FilterMonad Response m, WebMonad Response m) => String -> m b mkFailMessage s = do ignoreFilters - let res = setHeader "Content-Type" "text/html; charset=UTF-8" $ - resultBS 500 (LU.fromString (failHtml s)) - finishWith $ res + finishWith (failResponse s) +failResponse :: String -> Response +failResponse s = + setHeader "Content-Type" "text/html; charset=UTF-8" $ + resultBS 500 (LU.fromString (failHtml s)) + failHtml:: String->String failHtml errString = "" @@ -561,7 +647,7 @@ ------------------------------------------------------------------------------ -- ServerMonad, FilterMonad, and WebMonad instances for ReaderT, StateT, --- WriterT, and RWST +-- WriterT, RWST, and ErrorT ------------------------------------------------------------------------------ -- ReaderT @@ -580,49 +666,135 @@ -- StateT -instance (ServerMonad m) => ServerMonad (StateT s m) where +instance (ServerMonad m) => ServerMonad (Lazy.StateT s m) where askRq = lift askRq - localRq f = mapStateT (localRq f) + localRq f = Lazy.mapStateT (localRq f) -instance (FilterMonad res m) => FilterMonad res (StateT s m) where +instance (ServerMonad m) => ServerMonad (Strict.StateT s m) where + askRq = lift askRq + localRq f = Strict.mapStateT (localRq f) + +instance (FilterMonad res m) => FilterMonad res (Lazy.StateT s m) where setFilter f = lift $ setFilter f composeFilter = lift . composeFilter - getFilter m = mapStateT (\m' -> + getFilter m = Lazy.mapStateT (\m' -> do ((b,s), f) <- getFilter m' return ((b, f), s)) m -instance (WebMonad a m) => WebMonad a (StateT s m) where +instance (FilterMonad res m) => FilterMonad res (Strict.StateT s m) where + setFilter f = lift $ setFilter f + composeFilter = lift . composeFilter + getFilter m = Strict.mapStateT (\m' -> + do ((b,s), f) <- getFilter m' + return ((b, f), s)) m + +instance (WebMonad a m) => WebMonad a (Lazy.StateT s m) where finishWith = lift . finishWith +instance (WebMonad a m) => WebMonad a (Strict.StateT s m) where + finishWith = lift . finishWith -- WriterT -instance (ServerMonad m, Monoid w) => ServerMonad (WriterT w m) where +instance (ServerMonad m, Monoid w) => ServerMonad (Lazy.WriterT w m) where askRq = lift askRq - localRq f = mapWriterT (localRq f) + localRq f = Lazy.mapWriterT (localRq f) -instance (FilterMonad res m, Monoid w) => FilterMonad res (WriterT w m) where +instance (ServerMonad m, Monoid w) => ServerMonad (Strict.WriterT w m) where + askRq = lift askRq + localRq f = Strict.mapWriterT (localRq f) + +instance (FilterMonad res m, Monoid w) => FilterMonad res (Lazy.WriterT w m) where setFilter f = lift $ setFilter f composeFilter = lift . composeFilter - getFilter m = mapWriterT (\m' -> + getFilter m = Lazy.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 +instance (FilterMonad res m, Monoid w) => FilterMonad res (Strict.WriterT w m) where + setFilter f = lift $ setFilter f + composeFilter = lift . composeFilter + getFilter m = Strict.mapWriterT (\m' -> + do ((b,w), f) <- getFilter m' + return ((b, f), w)) m + +instance (WebMonad a m, Monoid w) => WebMonad a (Lazy.WriterT w m) where finishWith = lift . finishWith +instance (WebMonad a m, Monoid w) => WebMonad a (Strict.WriterT w m) where + finishWith = lift . finishWith + -- RWST -instance (ServerMonad m, Monoid w) => ServerMonad (RWST r w s m) where +instance (ServerMonad m, Monoid w) => ServerMonad (Lazy.RWST r w s m) where askRq = lift askRq - localRq f = mapRWST (localRq f) + localRq f = Lazy.mapRWST (localRq f) -instance (FilterMonad res m, Monoid w) => FilterMonad res (RWST r w s m) where +instance (ServerMonad m, Monoid w) => ServerMonad (Strict.RWST r w s m) where + askRq = lift askRq + localRq f = Strict.mapRWST (localRq f) + +instance (FilterMonad res m, Monoid w) => FilterMonad res (Lazy.RWST r w s m) where setFilter f = lift $ setFilter f composeFilter = lift . composeFilter - getFilter m = mapRWST (\m' -> + getFilter m = Lazy.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 +instance (FilterMonad res m, Monoid w) => FilterMonad res (Strict.RWST r w s m) where + setFilter f = lift $ setFilter f + composeFilter = lift . composeFilter + getFilter m = Strict.mapRWST (\m' -> + do ((b,s,w), f) <- getFilter m' + return ((b, f), s, w)) m + +instance (WebMonad a m, Monoid w) => WebMonad a (Lazy.RWST r w s m) where finishWith = lift . finishWith + +instance (WebMonad a m, Monoid w) => WebMonad a (Strict.RWST r w s m) where + finishWith = lift . finishWith + +-- ErrorT + +#if !MIN_VERSION_transformers(0,6,0) +instance (Error e, ServerMonad m) => ServerMonad (ErrorT e m) where + askRq = lift askRq + localRq f = mapErrorT $ localRq f + +instance (Error e, FilterMonad a m) => FilterMonad a (ErrorT e m) where + setFilter f = lift $ setFilter f + composeFilter = lift . composeFilter + getFilter m = mapErrorT (\m' -> + do (eb, f) <- getFilter m' + case eb of + (Left e) -> return (Left e) + (Right b) -> return $ Right (b, f) + ) m + +instance (Error e, WebMonad a m) => WebMonad a (ErrorT e m) where + finishWith = lift . finishWith +#endif + +-- ExceptT + +instance ServerMonad m => ServerMonad (ExceptT e m) where + askRq = lift askRq + localRq f = mapExceptT $ localRq f + +instance (FilterMonad a m) => FilterMonad a (ExceptT e m) where + setFilter f = lift $ setFilter f + composeFilter = lift . composeFilter + getFilter m = mapExceptT (\m' -> + do (eb, f) <- getFilter m' + case eb of + (Left e) -> return (Left e) + (Right b) -> return $ Right (b, f) + ) m + +instance WebMonad a m => WebMonad a (ExceptT e m) where + finishWith = lift . finishWith + +escapeHTTP :: (ServerMonad m, MonadIO m) => + (TimeoutIO -> IO ()) + -> m a +escapeHTTP h = liftIO (throwIO (EscapeHTTP h)) 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 @@ -72,11 +72,16 @@ -> IO (Bool, Int64 , FilePath) -- ^ truncated?, saved bytes, saved filename defaultFileSaver :: FilePath -> Int64 -> FilePath -> ByteString -> IO (Bool, Int64, FilePath) -defaultFileSaver tmpDir diskQuota filename b = +defaultFileSaver tmpDir diskQuota filename b + | pathSeparator filename = error ("Filename contains path separators: " ++ show filename) + | otherwise = do (fn, h) <- openBinaryTempFile tmpDir filename (trunc, len) <- hPutLimit diskQuota h b hClose h return (trunc, len, fn) + where + pathSeparator :: String -> Bool + pathSeparator template = any (\x-> x == '/' || x == '\\') template defaultInputIter :: FileSaver -> FilePath -> Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> Work -> IO InputIter defaultInputIter fileSaver tmpDir diskCount ramCount headerCount maxDisk maxRAM maxHeader (BodyWork ctype ps b) 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 @@ -44,6 +44,7 @@ ) where import Control.Monad +import Control.Monad.Fail (MonadFail) import Data.Char import Data.List import Text.ParserCombinators.Parsec @@ -53,7 +54,7 @@ pHeaders :: Parser [Header] pHeaders = many pHeader -parseHeaders :: Monad m => SourceName -> String -> m [Header] +parseHeaders :: MonadFail m => SourceName -> String -> m [Header] parseHeaders = parseM pHeaders pHeader :: Parser Header @@ -94,7 +95,11 @@ -- where nothing is escaped in the filename parameter -- of the content-disposition header in multipart/form-data let litStr = if p_name == "filename" - then buggyLiteralString + then choice [ try ((lookAhead $ do + void (literalString >> + p_parameter)) + >> literalString) + , buggyLiteralString] else literalString p_value <- litStr <|> p_token return (map toLower p_name, p_value) @@ -145,10 +150,10 @@ -- | Parse the standard representation of a content-type. -- If the input cannot be parsed, this function calls -- 'fail' with a (hopefully) informative error message. -parseContentType :: Monad m => String -> m ContentType +parseContentType :: MonadFail m => String -> m ContentType parseContentType = parseM pContentType "Content-type" -getContentType :: Monad m => [Header] -> m ContentType +getContentType :: MonadFail m => [Header] -> m ContentType getContentType hs = lookupM "content-type" hs >>= parseContentType -- @@ -165,11 +170,11 @@ c_cte <- p_token return $ ContentTransferEncoding (map toLower c_cte) -parseContentTransferEncoding :: Monad m => String -> m ContentTransferEncoding +parseContentTransferEncoding :: MonadFail m => String -> m ContentTransferEncoding parseContentTransferEncoding = parseM pContentTransferEncoding "Content-transfer-encoding" -getContentTransferEncoding :: Monad m => [Header] -> m ContentTransferEncoding +getContentTransferEncoding :: MonadFail m => [Header] -> m ContentTransferEncoding getContentTransferEncoding hs = lookupM "content-transfer-encoding" hs >>= parseContentTransferEncoding @@ -188,10 +193,10 @@ c_parameters <- many p_parameter return $ ContentDisposition (map toLower c_cd) c_parameters -parseContentDisposition :: Monad m => String -> m ContentDisposition +parseContentDisposition :: MonadFail m => String -> m ContentDisposition parseContentDisposition = parseM pContentDisposition "Content-disposition" -getContentDisposition :: Monad m => [Header] -> m ContentDisposition +getContentDisposition :: MonadFail m => [Header] -> m ContentDisposition getContentDisposition hs = lookupM "content-disposition" hs >>= parseContentDisposition @@ -199,13 +204,13 @@ -- * Utilities -- -parseM :: Monad m => Parser a -> SourceName -> String -> m a +parseM :: MonadFail m => Parser a -> SourceName -> String -> m a parseM p n inp = case parse p n inp of Left e -> fail (show e) Right x -> return x -lookupM :: (Monad m, Eq a, Show a) => a -> [(a,b)] -> m b +lookupM :: (MonadFail m, Eq a, Show a) => a -> [(a,b)] -> m b lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n -- diff --git a/src/Happstack/Server/Internal/Socket.hs b/src/Happstack/Server/Internal/Socket.hs --- a/src/Happstack/Server/Internal/Socket.hs +++ b/src/Happstack/Server/Internal/Socket.hs @@ -1,25 +1,13 @@ {-# LANGUAGE CPP #-} -#ifdef TEMPLATE_HASKELL -{-# LANGUAGE TemplateHaskell #-} -#endif module Happstack.Server.Internal.Socket ( acceptLite - , sockAddrToHostName + , sockAddrToPeer ) where import Data.List (intersperse) import Data.Word (Word32) -#ifdef TEMPLATE_HASKELL -import Happstack.Server.Internal.SocketTH(supportsIPv6) -import Language.Haskell.TH.Syntax -#endif - -import qualified Network as N - ( PortID(PortNumber) - , socketPort - ) import qualified Network.Socket as S - ( Socket(..) + ( Socket , PortNumber() , SockAddr(..) , HostName @@ -56,37 +44,12 @@ acceptLite :: S.Socket -> IO (S.Socket, S.HostName, S.PortNumber) acceptLite sock = do (sock', addr) <- S.accept sock - (N.PortNumber p) <- N.socketPort sock' - let peer = sockAddrToHostName addr - return (sock', peer, p) + let (peer, port) = sockAddrToPeer addr + return (sock', peer, port) -sockAddrToHostName :: S.SockAddr -> S.HostName -sockAddrToHostName addr = -#ifdef TEMPLATE_HASKELL - $(if supportsIPv6 - then - return $ CaseE (VarE (mkName "addr")) - [Match - (ConP (mkName "S.SockAddrInet") - [WildP,VarP (mkName "ha")]) - (NormalB (AppE (VarE (mkName "showHostAddress")) - (VarE (mkName "ha")))) [] - ,Match (ConP (mkName "S.SockAddrInet6") [WildP,WildP,VarP (mkName "ha"),WildP]) - (NormalB (AppE (VarE (mkName "showHostAddress6")) (VarE (mkName "ha")))) [] - ,Match WildP (NormalB (AppE (VarE (mkName "error")) (LitE (StringL "Unsupported socket")))) []] - -- the above mess is the equivalent of this: - {-[| case addr of - (S.SockAddrInet _ ha) -> showHostAddress ha - (S.SockAddrInet6 _ _ ha _) -> showHostAddress6 ha - _ -> error "Unsupported socket" - |]-} - else - [| case addr of - (S.SockAddrInet _ ha) -> showHostAddress ha - _ -> error "Unsupported socket" - |]) -#else - case addr of - (S.SockAddrInet _ ha) -> showHostAddress ha - _ -> error "Unsupported socket" -#endif +sockAddrToPeer :: S.SockAddr -> (S.HostName, S.PortNumber) +sockAddrToPeer addr = + case addr of + (S.SockAddrInet p ha) -> (showHostAddress ha, p) + (S.SockAddrInet6 p _ ha _) -> (showHostAddress6 ha, p) + _ -> error "sockAddrToPeer: Unsupported socket type" diff --git a/src/Happstack/Server/Internal/SocketTH.hs b/src/Happstack/Server/Internal/SocketTH.hs deleted file mode 100644 --- a/src/Happstack/Server/Internal/SocketTH.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE CPP #-} -#ifdef TEMPLATE_HASKELL -{-# LANGUAGE TemplateHaskell #-} -#endif -module Happstack.Server.Internal.SocketTH(supportsIPv6) where - -#ifdef TEMPLATE_HASKELL -import Language.Haskell.TH -#endif - -import Network.Socket(SockAddr(..)) - --- find out at compile time if the SockAddr6 / HostAddress6 constructors are available -supportsIPv6 :: Bool -#ifdef TEMPLATE_HASKELL -supportsIPv6 = $(let c = ["Network.Socket.SockAddrInet6", "Network.Socket.Internal.SockAddrInet6"] ; d = ''SockAddr - isInet6 :: Con -> Bool - isInet6 (NormalC n _) = show n `elem` c - isInet6 _ = False - in - do info <- reify d - case info of - TyConI (DataD _ _ _ cs _) -> - if any isInet6 cs - then [| True |] - else [| False |] - _ -> error "supportsIPv6: SockAddr is no longer a TyConI ?!?! Giving up." - ) -#else -supportsIPv6 = False -#endif diff --git a/src/Happstack/Server/Internal/TimeoutIO.hs b/src/Happstack/Server/Internal/TimeoutIO.hs --- a/src/Happstack/Server/Internal/TimeoutIO.hs +++ b/src/Happstack/Server/Internal/TimeoutIO.hs @@ -15,6 +15,7 @@ { toHandle :: Handle , toPutLazy :: L.ByteString -> IO () , toPut :: B.ByteString -> IO () + , toGet :: IO (Maybe B.ByteString) , toGetContents :: IO L.ByteString , toSendFile :: FilePath -> Offset -> ByteCount -> IO () , toShutdown :: IO () diff --git a/src/Happstack/Server/Internal/TimeoutManager.hs b/src/Happstack/Server/Internal/TimeoutManager.hs --- a/src/Happstack/Server/Internal/TimeoutManager.hs +++ b/src/Happstack/Server/Internal/TimeoutManager.hs @@ -8,6 +8,8 @@ , pause , resume , cancel + , forceTimeout + , forceTimeoutAll ) where import qualified Data.IORef as I @@ -68,3 +70,15 @@ cancel (Handle action iactive) = do I.writeIORef iactive $! Canceled I.writeIORef action $! (return ()) + +forceTimeout :: Handle -> IO () +forceTimeout (Handle action iactive) = + do I.writeIORef iactive $! Canceled + io <- I.atomicModifyIORef action (\io -> (return (), io)) + io `E.catch` ignoreAll + +-- | terminate all threads immediately +forceTimeoutAll :: Manager -> IO () +forceTimeoutAll (Manager ref) = + do hs <- I.atomicModifyIORef ref (\hs -> ([], hs)) + mapM_ forceTimeout hs diff --git a/src/Happstack/Server/Internal/TimeoutSocket.hs b/src/Happstack/Server/Internal/TimeoutSocket.hs --- a/src/Happstack/Server/Internal/TimeoutSocket.hs +++ b/src/Happstack/Server/Internal/TimeoutSocket.hs @@ -4,23 +4,24 @@ -} module Happstack.Server.Internal.TimeoutSocket where +import Control.Applicative (pure) import Control.Concurrent (threadWaitWrite) -import Control.Exception (catch, throw) +import Control.Exception as E (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 Network.Socket (sClose) +import Network.Socket (close) 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.Error (isDoesNotExistError) +import System.IO.Error (isDoesNotExistError, ioeGetErrorType) import System.IO.Unsafe (unsafeInterleaveIO) +import GHC.IO.Exception (IOErrorType(InvalidArgument)) sPutLazyTickle :: TM.Handle -> Socket -> L.ByteString -> IO () sPutLazyTickle thandle sock cs = @@ -34,6 +35,16 @@ return () {-# INLINE sPutTickle #-} +sGet :: TM.Handle + -> Socket + -> IO (Maybe B.ByteString) +sGet handle socket = + do s <- N.recv socket 65536 + TM.tickle handle + if S.null s + then pure Nothing + else pure (Just s) + sGetContents :: TM.Handle -> Socket -- ^ Connected socket -> IO L.ByteString -- ^ Data received @@ -42,8 +53,14 @@ s <- N.recv sock 65536 TM.tickle handle if S.null s - then do shutdown sock ShutdownReceive `catch` (\e -> when (not $ isDoesNotExistError e) (throw e)) - return L.Empty + then do + -- 'InvalidArgument' is GHCs code for eNOTCONN (among other + -- things). Sometimes the other end of socket is closed first + -- and this end is already disconnected before we do + -- 'shutdown'. Ignore this exception. + shutdown sock ShutdownReceive `E.catch` + (\e -> when (not (isDoesNotExistError e || ioeGetErrorType e == InvalidArgument)) (throw e)) + return L.Empty else L.Chunk s `liftM` loop @@ -71,8 +88,9 @@ timeoutSocketIO :: TM.Handle -> Socket -> TimeoutIO timeoutSocketIO handle socket = TimeoutIO { toHandle = handle - , toShutdown = sClose socket + , toShutdown = close socket , toPutLazy = sPutLazyTickle handle socket + , toGet = sGet handle socket , toPut = sPutTickle handle socket , toGetContents = sGetContents handle socket , toSendFile = sendFileTickle handle socket 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, RankNTypes, CPP #-} module Happstack.Server.Internal.Types (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..), @@ -13,12 +13,18 @@ redirect, -- redirect_, redirect', redirect'_, isHTTP1_0, isHTTP1_1, RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength, - HttpVersion(..), Length(..), Method(..), Headers, continueHTTP, + HttpVersion(..), Length(..), Method(..), canHaveBody, Headers, continueHTTP, Host, ContentType(..), - readDec', fromReadS, readM, FromReqURI(..) + readDec', fromReadS, readM, FromReqURI(..), + showRsValidator, EscapeHTTP(..) ) where -import Control.Monad.Error (Error(strMsg)) + +import Control.Exception (Exception, SomeException) +#if !MIN_VERSION_transformers(0,6,0) +import Control.Monad.Trans.Error (Error(strMsg)) +#endif +import Control.Monad.Fail (MonadFail) import Control.Monad.Trans (MonadIO(liftIO)) import qualified Control.Concurrent.Thread.Group as TG import Control.Concurrent.MVar @@ -26,7 +32,6 @@ 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 Data.ByteString.Char8 (ByteString,pack) import qualified Data.ByteString.Lazy.Char8 as L @@ -42,9 +47,9 @@ import Happstack.Server.Internal.RFC822Headers ( ContentType(..) ) import Happstack.Server.Internal.Cookie import Happstack.Server.Internal.LogFormat (formatRequestCombined) +import Happstack.Server.Internal.TimeoutIO (TimeoutIO) import Numeric (readDec, readSigned) import System.Log.Logger (Priority(..), logM) -import Text.Show.Functions () -- | HTTP version data HttpVersion = HttpVersion Int Int @@ -81,7 +86,7 @@ (rsfLength (rsFlags rs) /= NoContentLength || isNoMessageBodyResponse rs)) where isNoMessageBodyCode code = (code >= 100 && code <= 199) || code == 204 || code == 304 - isNoMessageBodyResponse rs = isNoMessageBodyCode (rsCode rs) && L.null (rsBody rs) + isNoMessageBodyResponse rs' = isNoMessageBodyCode (rsCode rs') && L.null (rsBody rs') -- | function to log access requests (see also: 'logMAccess') -- type LogAccess time = @@ -111,7 +116,7 @@ , validator :: Maybe (Response -> IO Response) -- ^ a function to validate the output on-the-fly , logAccess :: forall t. FormatTime t => Maybe (LogAccess t) -- ^ function to log access requests (see also: 'logMAccess') , timeout :: Int -- ^ number of seconds to wait before killing an inactive thread - , threadGroup :: Maybe TG.ThreadGroup -- ^ ThreadGroup for registering spawned threads for handling requests + , threadGroup :: Maybe TG.ThreadGroup -- ^ ThreadGroup for registering spawned threads for handling requests. } -- | Default configuration contains no validator and the port is set to 8000 @@ -132,9 +137,21 @@ logM "Happstack.Server.AccessLog.Combined" INFO $ formatRequestCombined host user time requestLine responseCode size referer userAgent -- | HTTP request method -data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT - deriving(Show,Read,Eq,Ord,Typeable,Data) +data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT | PATCH | EXTENSION ByteString + deriving (Show, Read, Eq, Ord, Data) +-- | Does the method support a message body? +-- +-- For extension methods, we assume yes. +canHaveBody :: Method + -> Bool +canHaveBody POST = True +canHaveBody PUT = True +canHaveBody PATCH = True +canHaveBody DELETE = True +canHaveBody (EXTENSION _) = True +canHaveBody _ = False + -- | an HTTP header data HeaderPair = HeaderPair { hName :: ByteString -- ^ header name @@ -161,7 +178,7 @@ -- | Result flags data RsFlags = RsFlags { rsfLength :: Length - } deriving (Show,Read,Typeable) + } deriving (Show, Read) -- | Default RsFlags: automatically use @Transfer-Encoding: Chunked@. nullRsFlags :: RsFlags @@ -186,7 +203,7 @@ { inputValue :: Either FilePath L.ByteString , inputFilename :: Maybe FilePath , inputContentType :: ContentType - } deriving (Show, Read, Typeable) + } deriving (Show, Read) -- | hostname & port type Host = (String, Int) -- ^ (hostname, port) @@ -207,52 +224,56 @@ , sfOffset :: Integer -- ^ offset to start at , sfCount :: Integer -- ^ number of bytes to send } - deriving (Typeable) instance Show Response where showsPrec _ res@Response{} = - showString "================== Response ================" . - showString "\nrsCode = " . shows (rsCode res) . - showString "\nrsHeaders = " . shows (rsHeaders res) . - showString "\nrsFlags = " . shows (rsFlags res) . - showString "\nrsBody = " . shows (rsBody res) . - showString "\nrsValidator = " . shows (rsValidator res) + showString "================== Response ================" . + showString "\nrsCode = " . shows (rsCode res) . + showString "\nrsHeaders = " . shows (rsHeaders res) . + showString "\nrsFlags = " . shows (rsFlags res) . + showString "\nrsBody = " . shows (rsBody res) . + showString "\nrsValidator = " . shows (showRsValidator (rsValidator res)) showsPrec _ res@SendFile{} = - showString "================== Response ================" . - showString "\nrsCode = " . shows (rsCode res) . - showString "\nrsHeaders = " . shows (rsHeaders res) . - showString "\nrsFlags = " . shows (rsFlags res) . - showString "\nrsValidator = " . shows (rsValidator res). - showString "\nsfFilePath = " . shows (sfFilePath res) . - showString "\nsfOffset = " . shows (sfOffset res) . + showString "================== Response ================" . + showString "\nrsCode = " . shows (rsCode res) . + showString "\nrsHeaders = " . shows (rsHeaders res) . + showString "\nrsFlags = " . shows (rsFlags res) . + showString "\nrsValidator = " . shows (showRsValidator (rsValidator res)) . + showString "\nsfFilePath = " . shows (sfFilePath res) . + showString "\nsfOffset = " . shows (sfOffset res) . showString "\nsfCount = " . shows (sfCount res) +showRsValidator :: Maybe (Response -> IO Response) -> String +showRsValidator = maybe "Nothing" (const "Just ") + +#if !MIN_VERSION_transformers(0,6,0) -- what should the status code be ? instance Error Response where strMsg str = setHeader "Content-Type" "text/plain; charset=UTF-8" $ result 500 str +#endif -- | an HTTP request 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) + { 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 + } instance Show Request where showsPrec _ rq = showString "================== Request =================" . - showString "\nrqSecure = " . shows (rqMethod rq) . + showString "\nrqSecure = " . shows (rqSecure rq) . showString "\nrqMethod = " . shows (rqMethod rq) . showString "\nrqPaths = " . shows (rqPaths rq) . showString "\nrqUri = " . showString (rqUri rq) . @@ -306,7 +327,7 @@ headers = id -- | The body of an HTTP 'Request' -newtype RqBody = Body { unBody :: L.ByteString } deriving (Read,Show,Typeable) +newtype RqBody = Body { unBody :: L.ByteString } deriving (Read, Show) -- | Sets the Response status code to the provided Int and lifts the computation -- into a Monad. @@ -318,7 +339,7 @@ mkHeaders :: [(String,String)] -> Headers mkHeaders hdrs = M.fromListWith join [ (P.pack (map toLower key), HeaderPair (P.pack key) [P.pack value]) | (key,value) <- hdrs ] - where join (HeaderPair key vs1) (HeaderPair _ vs2) = HeaderPair key (vs1++vs2) + where join (HeaderPair key vs1) (HeaderPair _ vs2) = HeaderPair key (vs2++vs1) -------------------------------------------------------------- -- Retrieving header information @@ -405,7 +426,7 @@ -- 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) + where join (HeaderPair k vs1) (HeaderPair _ vs2) = HeaderPair k (vs2++vs1) -- | Creates a Response with the given Int as the status code and the provided -- String as the body of the Response @@ -447,7 +468,7 @@ _ -> error "readDec' failed." -- | Read in any monad. -readM :: (Monad m, Read t) => String -> m t +readM :: (MonadFail m, Read t) => String -> m t readM s = case reads s of [(v,"")] -> return v _ -> fail "readM: parse error" @@ -500,3 +521,16 @@ "1" -> Just True "true" -> Just True _ -> Nothing + +------------------------------------------------------------------------------ +-- EscapeHTTP - escape hatched use by websockets +------------------------------------------------------------------------------ + +-- | Escape from the HTTP world and get direct access to the underlying 'TimeoutIO' functions +data EscapeHTTP + = EscapeHTTP (TimeoutIO -> IO ()) + +instance Exception EscapeHTTP + +instance Show EscapeHTTP where + show (EscapeHTTP {}) = "" diff --git a/src/Happstack/Server/Monads.hs b/src/Happstack/Server/Monads.hs --- a/src/Happstack/Server/Monads.hs +++ b/src/Happstack/Server/Monads.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, CPP #-} -- | This module provides four classes and some related functions -- which provide 'ServerPartT' with much of its web-centric behavior. -- @@ -31,20 +31,29 @@ -- * WebMonad , WebMonad(..) , escape - , escape' + , escape' -- * MonadPlus helpers , require , requireM + -- * escapeHTTP + , escapeHTTP ) where -import Control.Applicative (Alternative, Applicative) +import Control.Applicative (Alternative, Applicative) import Control.Monad (MonadPlus(mzero)) +#if !MIN_VERSION_transformers(0,6,0) +import Control.Monad.Trans.Error (Error, ErrorT) +#endif import Control.Monad.Trans (MonadIO(..),MonadTrans(lift)) +import Control.Monad.Trans.Except (ExceptT) 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 qualified Control.Monad.Writer.Lazy as Lazy (WriterT) +import qualified Control.Monad.Writer.Strict as Strict (WriterT) +import qualified Control.Monad.State.Lazy as Lazy (StateT) +import qualified Control.Monad.State.Strict as Strict (StateT) +import qualified Control.Monad.RWS.Lazy as Lazy (RWST) +import qualified Control.Monad.RWS.Strict as Strict (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) @@ -57,10 +66,17 @@ 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) +instance (Happstack m) => Happstack (Lazy.StateT s m) +instance (Happstack m) => Happstack (Strict.StateT s m) +instance (Happstack m) => Happstack (ReaderT r m) +instance (Happstack m, Monoid w) => Happstack (Lazy.WriterT w m) +instance (Happstack m, Monoid w) => Happstack (Strict.WriterT w m) +instance (Happstack m, Monoid w) => Happstack (Lazy.RWST r w s m) +instance (Happstack m, Monoid w) => Happstack (Strict.RWST r w s m) +#if !MIN_VERSION_transformers(0,6,0) +instance (Happstack m, Error e) => Happstack (ErrorT e m) +#endif +instance (Happstack m, Monoid e) => Happstack (ExceptT e m) -- | Get a header out of the request. getHeaderM :: (ServerMonad m) => String -> m (Maybe B.ByteString) @@ -99,5 +115,4 @@ case mbVal of Nothing -> mzero Just a -> handle a - diff --git a/src/Happstack/Server/Proxy.hs b/src/Happstack/Server/Proxy.hs deleted file mode 100644 --- a/src/Happstack/Server/Proxy.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} --- |Support for creating a proxy or reverse-proxy server -module Happstack.Server.Proxy where - -import Control.Monad (MonadPlus(mzero), liftM) -import Control.Monad.Trans (MonadIO(liftIO)) -import qualified Data.ByteString.Char8 as B -import Data.List (isPrefixOf) -import Data.Maybe (fromJust, fromMaybe) -import Happstack.Server.Monads (ServerMonad(askRq), FilterMonad, WebMonad, escape') -import Happstack.Server.Response (badGateway, toResponse) -import Happstack.Server.Client (getResponse) -import Happstack.Server.Types (Request(rqPaths, rqHeaders, rqPeer), Response, setHeader, getHeader) - --- | 'proxyServe' is for creating a part that acts as a proxy. The --- sole argument @['String']@ is a list of allowed domains for --- proxying. This matches the domain part of the request and the --- wildcard * can be used. E.g. --- --- * \"*\" to match anything. --- --- * \"*.example.com\" to match anything under example.com --- --- * \"example.com\" to match just example.com --- --- --- TODO: annoyingly enough, this method eventually calls 'escape', so --- any headers you set won't be used, and the computation immediately --- ends. -proxyServe :: (MonadIO m, WebMonad Response m, ServerMonad m, MonadPlus m, FilterMonad Response m) => [String] -> m Response -proxyServe allowed = do - rq <- askRq - if cond rq then proxyServe' rq else mzero - where - cond rq - | "*" `elem` allowed = True - | domain `elem` allowed = True - | superdomain `elem` wildcards =True - | otherwise = False - where - domain = head (rqPaths rq) - superdomain = tail $ snd $ break (=='.') domain - wildcards = (map (drop 2) $ filter ("*." `isPrefixOf`) allowed) - --- | Take a proxy 'Request' and create a 'Response'. Your basic proxy --- building block. See 'unproxify'. --- --- TODO: this would be more useful if it didn\'t call 'escape' --- (e.g. it let you modify the response afterwards, or set additional --- headers) -proxyServe' :: (MonadIO m, FilterMonad Response m, WebMonad Response m) => Request-> m Response -proxyServe' rq = liftIO (getResponse (unproxify rq)) >>= - either (badGateway . toResponse . show) escape' - --- | This is a reverse proxy implementation. See 'unrproxify'. --- --- TODO: this would be more useful if it didn\'t call 'escape', just --- like 'proxyServe''. -rproxyServe :: (ServerMonad m, WebMonad Response m, FilterMonad Response m, MonadIO m) => - String -- ^ defaultHost - -> [(String, String)] -- ^ map to look up hostname mappings. For the reverse proxy - -> m Response -- ^ the result is a 'ServerPartT' that will reverse proxy for you. -rproxyServe defaultHost list = - do rq <- askRq - r <- liftIO (getResponse (unrproxify defaultHost list rq)) - either (badGateway . toResponse . show) (escape') r - - -unproxify :: Request -> Request -unproxify rq = rq {rqPaths = tail $ rqPaths rq, - rqHeaders = - forwardedFor $ forwardedHost $ - setHeader "host" (head $ rqPaths rq) $ - rqHeaders rq} - where - appendInfo hdr val = setHeader hdr (csv val $ - maybe "" B.unpack $ - getHeader hdr rq) - forwardedFor = appendInfo "X-Forwarded-For" (fst $ rqPeer rq) - forwardedHost = appendInfo "X-Forwarded-Host" - (B.unpack $ fromJust $ getHeader "host" rq) - csv v "" = v - csv v x = x++", " ++ v - -unrproxify :: String -> [(String, String)] -> Request -> Request -unrproxify defaultHost list rq = - let host::String - host = fromMaybe defaultHost $ flip lookup list =<< B.unpack `liftM` getHeader "host" rq - newrq = rq {rqPaths = host: rqPaths rq} - in unproxify newrq - - 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 @@ -1,6 +1,6 @@ -{-# 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: -module Happstack.Server.Response +{-# LANGUAGE CPP, 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: +module Happstack.Server.Response ( -- * Converting values to a 'Response' ToMessage(..) , flatten @@ -26,6 +26,9 @@ , ifModifiedSince ) where +#if MIN_VERSION_xhtml(3000,3,0) +import qualified Data.ByteString.Builder as L +#endif import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.UTF8 as LU (fromString) @@ -34,24 +37,25 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT +import Data.Time (UTCTime, formatTime, defaultTimeLocale) import Happstack.Server.Internal.Monads (FilterMonad(composeFilter)) +import Happstack.Server.Internal.Types import Happstack.Server.Types (Response(..), Request(..), nullRsFlags, getHeader, noContentLength, redirect, result, setHeader, setHeaderBS) import Happstack.Server.SURI (ToSURI) -import System.Locale (defaultTimeLocale) -import System.Time (CalendarTime, formatCalendarTime) import qualified Text.Blaze.Html as Blaze import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze import Text.Html (Html, renderHtml) import qualified Text.XHtml as XHtml (Html, renderHtml) + -- | A low-level function to build a 'Response' from a content-type -- and a 'ByteString'. -- -- Creates a 'Response' in a manner similar to the 'ToMessage' class, -- but without requiring an instance declaration. --- +-- -- example: --- +-- -- > import Data.ByteString.Char8 as C -- > import Data.ByteString.Lazy.Char8 as L -- > import Happstack.Server @@ -85,13 +89,13 @@ -- -- > main = serve Nothing $ toResponse "hello, world!" -- --- Minimal definition: 'toMessage' (and usually 'toContentType'). +-- Minimal definition: 'toMessage' (and usually 'toContentType'). class ToMessage a where toContentType :: a -> B.ByteString toContentType _ = B.pack "text/plain" toMessage :: a -> L.ByteString toMessage = error "Happstack.Server.SimpleHTTP.ToMessage.toMessage: Not defined" - toResponse:: a -> Response + toResponse :: a -> Response toResponse val = let bs = toMessage val res = Response 200 M.empty nullRsFlags bs Nothing @@ -134,8 +138,11 @@ instance ToMessage XHtml.Html where toContentType _ = B.pack "text/html; charset=UTF-8" +#if MIN_VERSION_xhtml(3000,3,0) + toMessage = L.toLazyByteString . XHtml.renderHtml +#else toMessage = LU.fromString . XHtml.renderHtml - +#endif instance ToMessage Blaze.Html where toContentType _ = B.pack "text/html; charset=UTF-8" toMessage = Blaze.renderHtml @@ -174,12 +181,12 @@ -- If the 'Request' includes the @if-modified-since@ header and the -- 'Response' has not been modified, then return 304 (Not Modified), -- otherwise return the 'Response'. -ifModifiedSince :: CalendarTime -- ^ mod-time for the 'Response' (MUST NOT be later than server's time of message origination) +ifModifiedSince :: UTCTime -- ^ mod-time for the 'Response' (MUST NOT be later than server's time of message origination) -> Request -- ^ incoming request (used to check for if-modified-since) -> Response -- ^ Response to send if there are modifications -> Response ifModifiedSince modTime request response = - let repr = formatCalendarTime defaultTimeLocale "%a, %d %b %Y %X GMT" modTime + let repr = formatTime defaultTimeLocale "%a, %d %b %Y %X GMT" modTime notmodified = getHeader "if-modified-since" request == Just (B.pack $ repr) in if notmodified then noContentLength $ result 304 "" -- Not Modified @@ -194,31 +201,31 @@ -- -- A filter for setting the response code. Generally you will use a -- helper function like 'ok' or 'seeOther'. --- +-- -- > main = simpleHTTP nullConf $ do setResponseCode 200 -- > return "Everything is OK" --- +-- -- see also: 'resp' -setResponseCode :: FilterMonad Response m => +setResponseCode :: FilterMonad Response m => Int -- ^ response code -> m () setResponseCode code = composeFilter $ \r -> r{rsCode = code} -- | Same as @'setResponseCode' status >> return val@. --- +-- -- Use this if you want to set a response code that does not already --- have a helper function. --- +-- have a helper function. +-- -- > main = simpleHTTP nullConf $ resp 200 "Everything is OK" -resp :: (FilterMonad Response m) => +resp :: (FilterMonad Response m) => Int -- ^ response code -> b -- ^ value to return -> m b resp status val = setResponseCode status >> return val -- | Respond with @200 OK@. --- +-- -- > main = simpleHTTP nullConf $ ok "Everything is OK" ok :: (FilterMonad Response m) => a -> m a ok = resp 200 @@ -239,7 +246,7 @@ return res -- | Respond with @302 Found@. --- +-- -- You probably want 'seeOther'. This method is not in popular use anymore, and is generally treated like 303 by most user-agents anyway. found :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res found uri res = do modifyResponse $ redirect 302 uri @@ -284,7 +291,7 @@ forbidden = resp 403 -- | Respond with @404 Not Found@. --- +-- -- > main = simpleHTTP nullConf $ notFound "What you are looking for has not been found." notFound :: (FilterMonad Response m) => a -> m a notFound = resp 404 @@ -310,18 +317,18 @@ -- | A nicely formatted rendering of a 'Response' prettyResponse :: Response -> String prettyResponse res@Response{} = - showString "================== Response ================" . - showString "\nrsCode = " . shows (rsCode res) . - showString "\nrsHeaders = " . shows (rsHeaders res) . - showString "\nrsFlags = " . shows (rsFlags res) . - showString "\nrsBody = " . shows (rsBody res) . - showString "\nrsValidator = " $ show (rsValidator res) + showString "================== Response ================" . + showString "\nrsCode = " . shows (rsCode res) . + showString "\nrsHeaders = " . shows (rsHeaders res) . + showString "\nrsFlags = " . shows (rsFlags res) . + showString "\nrsBody = " . shows (rsBody res) . + showString "\nrsValidator = " $ showRsValidator (rsValidator res) prettyResponse res@SendFile{} = - showString "================== Response ================" . - showString "\nrsCode = " . shows (rsCode res) . - showString "\nrsHeaders = " . shows (rsHeaders res) . - showString "\nrsFlags = " . shows (rsFlags res) . - showString "\nrsValidator = " . shows (rsValidator res). - showString "\nsfFilePath = " . shows (sfFilePath res) . - showString "\nsfOffset = " . shows (sfOffset res) . - showString "\nsfCount = " $ show (sfCount res) + showString "================== Response ================" . + showString "\nrsCode = " . shows (rsCode res) . + showString "\nrsHeaders = " . shows (rsHeaders res) . + showString "\nrsFlags = " . shows (rsFlags res) . + showString "\nrsValidator = " . shows (showRsValidator (rsValidator res)) . + showString "\nsfFilePath = " . shows (sfFilePath res) . + showString "\nsfOffset = " . shows (sfOffset res) . + showString "\nsfCount = " $ show (sfCount res) diff --git a/src/Happstack/Server/Routing.hs b/src/Happstack/Server/Routing.hs --- a/src/Happstack/Server/Routing.hs +++ b/src/Happstack/Server/Routing.hs @@ -1,6 +1,6 @@ {-# 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: -module Happstack.Server.Routing +-- | Route an incoming 'Request' to a handler. For more in-depth documentation see this section of the Happstack Crash Course: +module Happstack.Server.Routing ( -- * Route by scheme http , https @@ -35,7 +35,7 @@ -- | instances of this class provide a variety of ways to match on the 'Request' method. -- -- Examples: --- +-- -- > method GET -- match GET or HEAD -- > method [GET, POST] -- match GET, HEAD or POST -- > method HEAD -- match HEAD /but not/ GET @@ -85,7 +85,7 @@ -- -- > handler :: ServerPart Response -- > handler = --- > do https +-- > do http -- > ... http :: (ServerMonad m, MonadPlus m) => m () http = guardRq (not . rqSecure) @@ -109,7 +109,7 @@ -- -- > handler :: ServerPart Response -- > handler = --- > do methodOnly [GET, HEAD] +-- > do method [GET, HEAD] -- > ... method :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m () method meth = guardRq $ \rq -> matchMethod meth (rqMethod rq) @@ -124,12 +124,12 @@ -- > handler = -- > do methodM [GET, HEAD] -- > ... --- +-- -- NOTE: This function is largely retained for backwards -- compatibility. The fact that implicitly calls 'nullDir' is often -- forgotten and leads to confusion. It is probably better to just use -- 'method' and call 'nullDir' explicitly. --- +-- -- This function will likely be deprecated in the future. methodM :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m () methodM meth = methodOnly meth >> nullDir @@ -153,7 +153,7 @@ -- -- > handler :: ServerPart Response -- > handler = methodSP [GET, HEAD] $ subHandler --- +-- -- NOTE: This style of combinator is going to be deprecated in the -- future. It is better to just use 'method'. -- @@ -166,16 +166,16 @@ -- | guard which only succeeds if there are no remaining path segments -- -- Often used if you want to explicitly assign a route for '/' --- +-- nullDir :: (ServerMonad m, MonadPlus m) => m () nullDir = guardRq $ \rq -> null (rqPaths rq) -- | Pop a path element and run the supplied handler if it matches the -- given string. --- +-- -- > handler :: ServerPart Response -- > handler = dir "foo" $ dir "bar" $ subHandler --- +-- -- The path element can not contain \'/\'. See also 'dirs'. dir :: (ServerMonad m, MonadPlus m) => String -> m a -> m a dir staticPath handle = @@ -184,17 +184,17 @@ case rqPaths rq of (p:xs) | p == staticPath -> localRq (\newRq -> newRq{rqPaths = xs}) handle _ -> mzero - + -- | Guard against a 'FilePath'. Unlike 'dir' the 'FilePath' may -- contain \'/\'. If the guard succeeds, the matched elements will be -- popped from the directory stack. -- -- > dirs "foo/bar" $ ... --- +-- -- See also: 'dir'. -dirs :: (ServerMonad m, MonadPlus m) => FilePath -> m a -> m a -dirs fp m = - do let parts = splitDirectories (makeRelative "/" fp) +dirs :: (ServerMonad m, MonadPlus m) => FilePath -> m a -> m a +dirs fp m = + do let parts = splitDirectories (makeRelative "/" fp) foldr dir m parts -- | Guard against the host. @@ -202,7 +202,11 @@ -- This matches against the @host@ header specified in the incoming 'Request'. -- -- Can be used to support virtual hosting, --- +-- +-- Note that this matches against the value of the @Host@ header which may include the port number. +-- +-- +-- -- see also: 'withHost' host :: (ServerMonad m, MonadPlus m) => String -> m a -> m a host desiredHost handle = @@ -238,7 +242,7 @@ uriRest handle = askRq >>= handle . rqURL -- | Pop any path element and run the handler. --- +-- -- Succeeds if a path component was popped. Fails is the remaining path was empty. anyPath :: (ServerMonad m, MonadPlus m) => m r -> m r anyPath x = path $ (\(_::String) -> x) diff --git a/src/Happstack/Server/RqData.hs b/src/Happstack/Server/RqData.hs --- a/src/Happstack/Server/RqData.hs +++ b/src/Happstack/Server/RqData.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} --- | Functions for extracting values from the query string, form data, cookies, etc. +{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-} +-- | Functions for extracting values from the query string, form data, cookies, etc. -- -- For in-depth documentation see the following section of the Happstack Crash Course: -- --- -module Happstack.Server.RqData +-- +module Happstack.Server.RqData ( -- * Looking up keys -- ** Form Values and Query Parameters look @@ -29,13 +29,13 @@ , lookInputs -- * Filters -- The look* functions normally search the QUERY_STRING and the Request - -- body for matches keys. + -- body for matches keys. , body , queryString , bytestring -- * Validation and Parsing , checkRq - , checkRqM + , checkRqM , readRq , unsafeReadRq -- * Handling POST\/PUT Requests @@ -46,7 +46,7 @@ -- * RqData Monad & Error Reporting , RqData , mapRqData - , Errors(..) + , Errors(..) -- ** Using RqData with ServerMonad , getDataFn , withDataFn @@ -58,46 +58,71 @@ , HasRqData(askRqEnv, localRqEnv,rqDataError) ) where -import Control.Applicative (Applicative((<*>), pure), Alternative((<|>), empty), WrappedMonad(WrapMonad, unwrapMonad), (<$>)) -import Control.Concurrent.MVar (newMVar) -import Control.Monad (MonadPlus(mzero)) +import Control.Applicative (Applicative((<*>), pure), Alternative((<|>), empty), WrappedMonad(WrapMonad, unwrapMonad)) +import Control.Monad (MonadPlus(mzero, mplus)) 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 qualified Control.Monad.State.Lazy as Lazy (StateT, mapStateT) +import qualified Control.Monad.State.Strict as Strict (StateT, mapStateT) +import qualified Control.Monad.Writer.Lazy as Lazy (WriterT, mapWriterT) +import qualified Control.Monad.Writer.Strict as Strict (WriterT, mapWriterT) +import qualified Control.Monad.RWS.Lazy as Lazy (RWST, mapRWST) +import qualified Control.Monad.RWS.Strict as Strict (RWST, mapRWST) +#if !MIN_VERSION_transformers(0,6,0) +import qualified Control.Monad.Trans.Error as DeprecatedError +#endif +import Control.Monad.Except (throwError) import Control.Monad.Trans (MonadIO(..), lift) +import Control.Monad.Trans.Except (ExceptT, mapExceptT) import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.UTF8 as LU import Data.Char (toLower) import Data.Either (partitionEithers) -import Data.Generics (Data, Typeable) -import Data.Maybe (fromMaybe, fromJust) +import Data.Generics (Data) +import Data.Maybe (fromJust) import Data.Monoid (Monoid(mempty, mappend, mconcat)) +import qualified Data.Semigroup as SG import Data.Text (Text) import qualified Data.Text.Lazy as LazyText import qualified Data.Text.Lazy.Encoding as LazyText import Happstack.Server.Cookie (Cookie (cookieValue)) -import Happstack.Server.Internal.Monads (ServerMonad(askRq, localRq), FilterMonad, WebMonad, ServerPartT, escape) -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.Monads +import Happstack.Server.Types import Happstack.Server.Internal.MessageWrap (BodyPolicy(..), bodyInput, defaultBodyPolicy) import Happstack.Server.Response (requestEntityTooLarge, toResponse) +import Network.URI (unEscapeString) newtype ReaderError r e a = ReaderError { unReaderError :: ReaderT r (Either e) a } - deriving (Functor, Monad, MonadPlus) + deriving (Functor, Monad) -instance (Error e) => MonadReader r (ReaderError r e) where +#if MIN_VERSION_transformers(0,6,0) +deriving instance (Monoid e, MonadPlus (Either e)) => MonadPlus (ReaderError r e) +#else +deriving instance (Monoid e, DeprecatedError.Error e, MonadPlus (Either e)) => MonadPlus (ReaderError r e) +#endif + +#if MIN_VERSION_transformers(0,6,0) +instance (Monoid e) => MonadReader r (ReaderError r e) where +#else +instance (DeprecatedError.Error e, Monoid e) => MonadReader r (ReaderError r e) where +#endif ask = ReaderError ask local f m = ReaderError $ local f (unReaderError m) -instance (Monoid e, Error e) => Applicative (ReaderError r e) where +#if MIN_VERSION_transformers(0,6,0) +instance (Monoid e) => Applicative (ReaderError r e) where +#else +instance (Monoid e, DeprecatedError.Error e) => Applicative (ReaderError r e) where +#endif pure = return - (ReaderError (ReaderT f)) <*> (ReaderError (ReaderT a)) + (ReaderError (ReaderT f)) <*> (ReaderError (ReaderT a)) = ReaderError $ ReaderT $ \env -> (f env) `apEither` (a env) -instance (Monoid e, Error e) => Alternative (ReaderError r e) where +#if MIN_VERSION_transformers(0,6,0) +instance (MonadPlus (Either e), Monoid e) => Alternative (ReaderError r e) where +#else +instance (Monoid e, DeprecatedError.Error e) => Alternative (ReaderError r e) where +#endif empty = unwrapMonad empty f <|> g = unwrapMonad $ (WrapMonad f) <|> (WrapMonad g) @@ -109,18 +134,38 @@ -- | a list of errors newtype Errors a = Errors { unErrors :: [a] } - deriving (Eq, Ord, Show, Read, Data, Typeable) + deriving (Eq, Ord, Show, Read, Data) +instance SG.Semigroup (Errors a) where + (Errors x) <> (Errors y) = Errors (x ++ y) + instance Monoid (Errors a) where mempty = Errors [] - (Errors x) `mappend` (Errors y) = Errors (x ++ y) + mappend = (SG.<>) mconcat errs = Errors $ concatMap unErrors errs -instance Error (Errors String) where +#if MIN_VERSION_transformers(0,6,0) +instance (Alternative (Either (Errors a))) => MonadPlus (Either (Errors a)) where + mzero = Left (Errors []) + (Left _) `mplus` n = n + m `mplus` _ = m + +instance Alternative (Either (Errors a)) where + empty = Left (Errors []) + (Left _) <|> n = n + m <|> _ = m +#endif + +#if !MIN_VERSION_transformers(0,6,0) +instance DeprecatedError.Error (Errors String) where noMsg = Errors [] strMsg str = Errors [str] +#endif -{- commented out to avoid 'Defined but not used' warning. +strMsg :: a -> Errors a +strMsg errMsg = Errors [errMsg] + +{- 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 ()) @@ -145,7 +190,7 @@ askRqEnv :: m RqEnv localRqEnv :: (RqEnv -> RqEnv) -> m a -> m a -- | lift some 'Errors' into 'RqData' - rqDataError :: Errors String -> m a + rqDataError :: Errors String -> m a instance HasRqData RqData where askRqEnv = RqData ask @@ -153,36 +198,13 @@ rqDataError e = mapRqData ((Left e) `apEither`) (return ()) -- instance (MonadPlus m, MonadIO m, ServerMonad m) => (HasRqData m) where -instance (MonadIO m) => HasRqData (ServerPartT m) where - askRqEnv = - do rq <- askRq - mbi <- liftIO $ if ((rqMethod rq == POST) || (rqMethod rq == PUT)) && (isDecodable (ctype rq)) - then readInputsBody rq - else return (Just []) - return (rqInputsQuery rq, mbi, rqCookies rq) - where - ctype :: Request -> Maybe ContentType - ctype req = parseContentType . P.unpack =<< getHeader "content-type" req - 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 _) = False - +instance (MonadIO m, MonadPlus m) => HasRqData (ServerPartT m) where + askRqEnv = smAskRqEnv rqDataError _e = mzero - localRqEnv f m = - do rq <- askRq - b <- liftIO $ readInputsBody rq - let (q', b', c') = f (rqInputsQuery rq, b, rqCookies rq) - bv <- liftIO $ newMVar (fromMaybe [] b') - let rq' = rq { rqInputsQuery = q' - , rqInputsBody = bv - , rqCookies = c' - } - localRq (const rq') m + localRqEnv = smLocalRqEnv ------------------------------------------------------------------------------ --- HasRqData instances for ReaderT, StateT, WriterT, and RWST +-- HasRqData instances for ReaderT, StateT, WriterT, RWST, and ErrorT ------------------------------------------------------------------------------ instance (Monad m, HasRqData m) => HasRqData (ReaderT s m) where @@ -190,21 +212,48 @@ localRqEnv f = mapReaderT (localRqEnv f) rqDataError e = lift (rqDataError e) -instance (Monad m, HasRqData m) => HasRqData (StateT s m) where +instance (Monad m, HasRqData m) => HasRqData (Lazy.StateT s m) where askRqEnv = lift askRqEnv - localRqEnv f = mapStateT (localRqEnv f) + localRqEnv f = Lazy.mapStateT (localRqEnv f) rqDataError e = lift (rqDataError e) -instance (Monad m, HasRqData m, Monoid w) => HasRqData (WriterT w m) where +instance (Monad m, HasRqData m) => HasRqData (Strict.StateT s m) where askRqEnv = lift askRqEnv - localRqEnv f = mapWriterT (localRqEnv f) + localRqEnv f = Strict.mapStateT (localRqEnv f) rqDataError e = lift (rqDataError e) -instance (Monad m, HasRqData m, Monoid w) => HasRqData (RWST r w s m) where +instance (Monad m, HasRqData m, Monoid w) => HasRqData (Lazy.WriterT w m) where askRqEnv = lift askRqEnv - localRqEnv f = mapRWST (localRqEnv f) + localRqEnv f = Lazy.mapWriterT (localRqEnv f) rqDataError e = lift (rqDataError e) +instance (Monad m, HasRqData m, Monoid w) => HasRqData (Strict.WriterT w m) where + askRqEnv = lift askRqEnv + localRqEnv f = Strict.mapWriterT (localRqEnv f) + rqDataError e = lift (rqDataError e) + +instance (Monad m, HasRqData m, Monoid w) => HasRqData (Lazy.RWST r w s m) where + askRqEnv = lift askRqEnv + localRqEnv f = Lazy.mapRWST (localRqEnv f) + rqDataError e = lift (rqDataError e) + +instance (Monad m, HasRqData m, Monoid w) => HasRqData (Strict.RWST r w s m) where + askRqEnv = lift askRqEnv + localRqEnv f = Strict.mapRWST (localRqEnv f) + rqDataError e = lift (rqDataError e) + +#if !MIN_VERSION_transformers(0,6,0) +instance (Monad m, DeprecatedError.Error e, HasRqData m) => HasRqData (DeprecatedError.ErrorT e m) where + askRqEnv = lift askRqEnv + localRqEnv f = DeprecatedError.mapErrorT (localRqEnv f) + rqDataError e = lift (rqDataError e) +#endif + +instance (Monad m, HasRqData m) => HasRqData (ExceptT e m) where + askRqEnv = lift askRqEnv + localRqEnv f = mapExceptT (localRqEnv f) + rqDataError e = lift (rqDataError e) + -- | apply 'RqData a' to a 'RqEnv' -- -- see also: 'getData', 'getDataFn', 'withData', 'withDataFn', 'RqData', 'getDataFn' @@ -222,7 +271,7 @@ -- | use 'read' to convert a 'String' to a value of type 'a' -- -- > look "key" `checkRq` (unsafeReadRq "key") --- +-- -- use with 'checkRq' -- -- NOTE: This function is marked unsafe because some Read instances @@ -232,7 +281,7 @@ -- > read "1e10000000000000" :: Integer -- -- see also: 'readRq' -unsafeReadRq :: (Read a) => +unsafeReadRq :: (Read a) => String -- ^ name of key (only used for error reporting) -> String -- ^ 'String' to 'read' -> Either String a -- ^ 'Left' on error, 'Right' on success @@ -240,13 +289,13 @@ case reads val of [(a,[])] -> Right a _ -> Left $ "readRq failed while parsing key: " ++ key ++ " which has the value: " ++ val - + -- | use 'fromReqURI' to convert a 'String' to a value of type 'a' -- -- > look "key" `checkRq` (readRq "key") --- +-- -- use with 'checkRq' -readRq :: (FromReqURI a) => +readRq :: (FromReqURI a) => String -- ^ name of key (only used for error reporting) -> String -- ^ 'String' to 'read' -> Either String a -- ^ 'Left' on error, 'Right' on success @@ -255,7 +304,6 @@ (Just a) -> Right a _ -> Left $ "readRq failed while parsing key: " ++ key ++ " which has the value: " ++ val - -- | convert or validate a value -- -- This is similar to 'fmap' except that the function can fail by @@ -263,7 +311,7 @@ -- by calling 'rqDataError'. -- -- This function is useful for a number of things including: --- +-- -- (1) Parsing a 'String' into another type -- -- (2) Checking that a value meets some requirements (for example, that is an Int between 1 and 10). @@ -322,7 +370,7 @@ (Just bdy) -> bdy -- | Gets the first matching named input parameter --- +-- -- Searches the QUERY_STRING followed by the Request body. -- -- see also: 'lookInputs' @@ -335,7 +383,7 @@ Nothing -> rqDataError (strMsg $ "Parameter not found: " ++ name) -- | Gets all matches for the named input parameter --- +-- -- Searches the QUERY_STRING followed by the Request body. -- -- see also: 'lookInput' @@ -351,7 +399,7 @@ -- -- see also: 'lookBSs' lookBS :: (Functor m, Monad m, HasRqData m) => String -> m L.ByteString -lookBS n = +lookBS n = do i <- fmap inputValue (lookInput n) case i of (Left _fp) -> rqDataError $ (strMsg $ "lookBS: " ++ n ++ " is a file.") @@ -363,7 +411,7 @@ -- -- see also: 'lookBS' lookBSs :: (Functor m, Monad m, HasRqData m) => String -> m [L.ByteString] -lookBSs n = +lookBSs n = do is <- fmap (map inputValue) (lookInputs n) case partitionEithers is of ([], bs) -> return bs @@ -443,7 +491,9 @@ = do (_query,_body, cookies) <- askRqEnv case lookup (map toLower name) cookies of -- keys are lowercased Nothing -> rqDataError $ strMsg $ "lookCookie: cookie not found: " ++ name - Just c -> return c + Just c -> return c{cookieValue = f c} + where + f = unEscapeString . cookieValue -- | gets the named cookie as a string lookCookieValue :: (Functor m, Monad m, HasRqData m) => String -> m String @@ -471,7 +521,7 @@ -- -- see also: 'lookReads' lookReads :: (Functor m, Monad m, HasRqData m, FromReqURI a) => String -> m [a] -lookReads name = +lookReads name = do vals <- looks name mapM (\v -> (return v) `checkRq` (readRq name)) vals @@ -481,7 +531,7 @@ -- must set enctype=\"multipart\/form-data\". -- -- This function returns a tuple consisting of: --- +-- -- (1) The temporary location of the uploaded file -- -- (2) The local filename supplied by the browser @@ -493,7 +543,7 @@ -- a 0-length file with an empty file name, so checking that (2) is -- not empty is usually sufficient to ensure the field has been -- filled. --- +-- -- NOTE: You must move the file from the temporary location before the -- 'Response' is sent. The temporary files are automatically removed -- after the 'Response' is sent. @@ -515,7 +565,7 @@ -- -- see also: 'lookPairsBS' lookPairs :: (Monad m, HasRqData m) => m [(String, Either FilePath String)] -lookPairs = +lookPairs = do (query, mBody, _cookies) <- askRqEnv 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) @@ -527,20 +577,20 @@ -- -- see also: 'lookPairs' lookPairsBS :: (Monad m, HasRqData m) => m [(String, Either FilePath L.ByteString)] -lookPairsBS = +lookPairsBS = do (query, mBody, _cookies) <- askRqEnv 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. +-- | The body of a 'Request' is not received or decoded unless +-- this function is invoked. -- --- It is an error to try to use the look functions for a POST\/PUT --- request with out first calling this function. +-- It is an error to try to use the look functions for a +-- 'Request' with out first calling this function. -- -- It is ok to call 'decodeBody' at the beginning of every request: -- --- > main = simpleHTTP nullConf $ +-- > main = simpleHTTP nullConf $ -- > do decodeBody (defaultBodyPolicy "/tmp/" 4096 4096 4096) -- > handlers -- @@ -584,7 +634,7 @@ -- > (Right a) | otherwise -> errorHandler "invalid" -- -- NOTE: you must call 'decodeBody' prior to calling this function if --- the request method is POST or PUT. +-- the request method is POST, PUT, PATCH, etc. getDataFn :: (HasRqData m, ServerMonad m) => RqData a -- ^ 'RqData' monad to evaluate -> m (Either [String] a) -- ^ return 'Left' errors or 'Right' a @@ -594,15 +644,15 @@ -- | similar to 'getDataFn', except it calls a sub-handler on success -- or 'mzero' on failure. --- +-- -- NOTE: you must call 'decodeBody' prior to calling this function if --- the request method is POST or PUT. +-- the request method is POST, PUT, PATCH, etc. withDataFn :: (HasRqData m, MonadPlus m, ServerMonad m) => RqData a -> (a -> m r) -> m r withDataFn fn handle = getDataFn fn >>= either (const mzero) handle -- | A variant of 'getDataFn' that uses 'FromData' to chose your -- 'RqData' for you. The example from 'getData' becomes: --- +-- -- > data AuthCredentials = AuthCredentials { username :: String, password :: String } -- > -- > isValid :: AuthCredentials -> Bool @@ -626,14 +676,14 @@ -- > (Right a) | otherwise -> errorHandler "invalid" -- -- NOTE: you must call 'decodeBody' prior to calling this function if --- the request method is POST or PUT. +-- the request method is POST, PUT, PATCH, etc. getData :: (HasRqData m, ServerMonad m, FromData a) => m (Either [String] a) getData = getDataFn fromData -- | similar to 'getData' except it calls a subhandler on success or 'mzero' on failure. -- -- NOTE: you must call 'decodeBody' prior to calling this function if --- the request method is POST or PUT. +-- the request method is POST, PUT, PATCH, etc. withData :: (HasRqData m, FromData a, MonadPlus m, ServerMonad m) => (a -> m r) -> m r withData = withDataFn fromData 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 @@ -1,13 +1,32 @@ {-# 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 +-- | 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 + ( path + , query + , scheme + , u_scheme + , u_path + , a_scheme + , a_path + , percentDecode + , unEscape + , unEscapeQS + , isAbs + , SURI(..) + , render + , parse + , ToSURI(..) + , FromPath(..) + ) + where import Control.Arrow (first) -import Data.Maybe -import Data.Generics -import qualified Data.Text as Text +import Data.Char (chr, digitToInt, isHexDigit) +import Data.Maybe (fromJust, isJust) +import Data.Generics (Data) +import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText -import qualified Network.URI as URI +import qualified Network.URI as URI -- | Retrieves the path component from the URI path :: SURI -> String @@ -37,20 +56,29 @@ a_path :: String -> SURI -> SURI a_path a (SURI u) = SURI $ u {URI.uriPath=a} -escape, unEscape, unEscapeQS :: String -> String -unEscapeQS = URI.unEscapeString . map (\x->if x=='+' then ' ' else x) -unEscape = URI.unEscapeString -escape = URI.escapeURIString URI.isAllowedInURI +-- | percent decode a String +-- +-- e.g. @\"hello%2Fworld\"@ -> @\"hello/world\"@ +percentDecode :: String -> String +percentDecode [] = "" +percentDecode ('%':x1:x2:s) | isHexDigit x1 && isHexDigit x2 = + chr (digitToInt x1 * 16 + digitToInt x2) : percentDecode s +percentDecode (c:s) = c : percentDecode s +unEscape, unEscapeQS :: String -> String +unEscapeQS = percentDecode . map (\x->if x=='+' then ' ' else x) +unEscape = percentDecode +-- escape = URI.escapeURIString URI.isAllowedInURI + -- | Returns true if the URI is absolute isAbs :: SURI -> Bool isAbs = not . null . URI.uriScheme . suri -newtype SURI = SURI {suri::URI.URI} deriving (Eq,Data,Typeable) +newtype SURI = SURI {suri::URI.URI} deriving (Eq,Data) instance Show SURI where showsPrec d (SURI uri) = showsPrec d $ show uri instance Read SURI where - readsPrec d = mapFst fromJust . filter (isJust . fst) . mapFst parse . readsPrec d + readsPrec d = mapFst fromJust . filter (isJust . fst) . mapFst parse . readsPrec d where mapFst :: (a -> b) -> [(a,x)] -> [(b,x)] mapFst = map . first @@ -64,14 +92,14 @@ -- | Parses a URI from a String. Returns Nothing on failure. parse :: String -> Maybe SURI -parse = fmap SURI . URI.parseURIReference +parse = fmap SURI . URI.parseURIReference -- | Convenience class for converting data types to URIs class ToSURI x where toSURI::x->SURI instance ToSURI SURI where toSURI=id instance ToSURI URI.URI where toSURI=SURI -instance ToSURI String where +instance ToSURI String where toSURI = maybe (SURI $ URI.URI "" Nothing "" "" "") id . parse instance ToSURI Text.Text where toSURI = toSURI . Text.unpack instance ToSURI LazyText.Text where toSURI = toSURI . LazyText.unpack 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 @@ -26,13 +26,13 @@ -- run a 'ServerPart'. -- -- A very simple, \"Hello World!\" web app looks like: --- +-- -- > import Happstack.Server -- > main = simpleHTTP nullConf $ ok "Hello World!" -- --- By default the server will listen on port 8000. Run the app and point your browser at: +-- By default the server will listen on port 8000. Run the app and point your browser at: -- --- For FastCGI support see: +-- For FastCGI support see: ----------------------------------------------------------------------------- module Happstack.Server.SimpleHTTP ( -- * SimpleHTTP @@ -44,6 +44,7 @@ , bindPort , bindIPv4 , parseConfig + , runWebT , waitForTermination -- * Re-exported modules -- ** Basic ServerMonad functionality @@ -58,8 +59,6 @@ , module Happstack.Server.Response -- ** Request Routing , module Happstack.Server.Routing - -- ** Proxying - , module Happstack.Server.Proxy -- ** Looking up values in Query String, Request Body, and Cookies , module Happstack.Server.RqData -- ** Output Validation @@ -76,19 +75,17 @@ import Happstack.Server.Cookie import Happstack.Server.Error import Happstack.Server.Types -import Happstack.Server.Proxy import Happstack.Server.Routing import Happstack.Server.RqData import Happstack.Server.Response import Happstack.Server.Validation - import Control.Monad import Data.Maybe (fromMaybe) 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 Network (Socket) +import Network.Socket (Socket) import qualified Paths_happstack_server as Cabal import System.Console.GetOpt ( OptDescr(Option) , ArgDescr(ReqArg) @@ -127,7 +124,7 @@ -- | A combination of 'simpleHTTP''' and 'mapServerPartT'. See -- 'mapServerPartT' for a discussion of the first argument of this --- function. +-- function. -- -- NOTE: This function always binds to IPv4 ports until Network -- module is fixed to support IPv6 in a portable way. Use @@ -138,7 +135,6 @@ simpleHTTP' toIO conf hs = Listen.listen conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req)) - -- | Generate a result from a 'ServerPartT' and a 'Request'. This is -- mainly used by CGI (and fast-cgi) wrappers. simpleHTTP'' :: (ToMessage b, Monad m, Functor m) => ServerPartT m b -> Request -> m Response @@ -186,8 +182,8 @@ -- > main = do let conf = nullConf -- > addr = "127.0.0.1" -- > s <- bindIPv4 addr (port conf) --- > simpleHTTPWithSocket s conf $ ok $ toResponse $ --- > "now listening on ip addr " ++ addr ++ +-- > simpleHTTPWithSocket s conf $ ok $ toResponse $ +-- > "now listening on ip addr " ++ addr ++ -- > " and port " ++ show (port conf) -- bindIPv4 :: String -- ^ IP address to bind to (must be an IP address and not a host name) @@ -204,7 +200,7 @@ appFilterToResp (e, ff) = unFilterFun ff $ either id toResponse e notFoundHtml :: String -notFoundHtml = +notFoundHtml = "" ++ "Happstack " ++ ver ++ " File not found" @@ -218,7 +214,7 @@ -- | Wait for a signal. -- On unix, a signal is sigINT or sigTERM (aka Control-C). --- +-- -- On windows, the signal is entering: e waitForTermination :: IO () waitForTermination @@ -233,7 +229,7 @@ False -> return () takeMVar mv #else - let loop 'e' = return () + let loop 'e' = return () loop _ = getChar >>= loop loop 'c' #endif diff --git a/tests/Happstack/Server/Tests.hs b/tests/Happstack/Server/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Happstack/Server/Tests.hs @@ -0,0 +1,262 @@ +-- |HUnit tests and QuickQuick properties for Happstack.Server.* +module Happstack.Server.Tests (allTests) where + +import qualified Codec.Compression.GZip as GZ +import qualified Codec.Compression.Zlib as Z +import Control.Arrow ((&&&)) +import Control.Applicative ((<$>)) +import Control.Concurrent.MVar +import Control.Monad +import Data.ByteString.Lazy.Char8 (pack, unpack) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as L +import Data.List (intercalate) +import qualified Data.Map as Map +import Happstack.Server ( Request(..), Method(..), Response(..), ServerPart, Headers, RqBody(Body), HttpVersion(..) + , ToMessage(..), HeaderPair(..), ok, dir, simpleHTTP'', composeFilter, noContentLength, matchMethod + , look, getDataFn) +import Happstack.Server.FileServe.BuildingBlocks (sendFileResponse) +import Happstack.Server.Cookie +import Happstack.Server.Internal.Compression +import Happstack.Server.Internal.Cookie +import Happstack.Server.Internal.Multipart +import Happstack.Server.Internal.MessageWrap +import Happstack.Server.Internal.RFC822Headers (ContentDisposition(..), parseContentDisposition) +import Happstack.Server.SURI(ToSURI(..), path, query) +import Test.HUnit as HU (Test(..), (~:), (@?=), (@=?), assertEqual) +import Text.ParserCombinators.Parsec + +-- |All of the tests for happstack-util should be listed here. +allTests :: Test +allTests = + "happstack-server tests" ~: [ cookieParserTest + , acceptEncodingParserTest + , multipart + , compressFilterResponseTest + , matchMethodTest + , cookieHeaderOrderTest + , pContentDispositionFilename + , applicativeTest + ] + +cookieParserTest :: Test +cookieParserTest = + "cookieParserTest" ~: + [parseCookies "$Version=1;Cookie1=value1;$Path=\"/testpath\";$Domain=example.com;cookie2=value2" + @?= (Right [ + Cookie "1" "/testpath" "example.com" "cookie1" "value1" False False SameSiteNoValue False + , Cookie "1" "" "" "cookie2" "value2" False False SameSiteNoValue False + ]) + ,parseCookies " \t $Version = \"1\" ; cookie1 = \"randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|\" , $Path=/ " + @?= (Right [ + Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/|" False False SameSiteNoValue False + ]) + ,parseCookies " cookie1 = value1 " + @?= (Right [ + Cookie "" "" "" "cookie1" "value1" False False SameSiteNoValue False + ]) + ,parseCookies " $Version=\"1\";buggygooglecookie = valuewith=whereitshouldnotbe " + @?= (Right [ + Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" False False SameSiteNoValue False + ]) + , parseCookies "foo=\"\\\"bar\\\"\"" + @?= (Right [ + Cookie "" "" "" "foo" "\"bar\"" False False SameSiteNoValue False + ]) + ] + +acceptEncodingParserTest :: Test +acceptEncodingParserTest = + "acceptEncodingParserTest" ~: + map (\(str, result) -> either (Left . show) Right (parse encodings "" str) @?= (Right result)) acceptEncodings + where + acceptEncodings = + [ (" gzip;q=1,*, compress ; q = 0.5 ", [("gzip", Just 1),("*", Nothing),("compress", Just 0.5)]) + , (" compress , gzip", [ ("compress", Nothing), ("gzip", Nothing)]) + , (" ", []) + , (" *", [("*", Nothing)]) + , (" compress;q=0.5, gzip;q=1.0", [("compress", Just 0.5), ("gzip", Just 1.0)]) + , (" gzip;q=1.0, identity; q=0.5, *;q=0", [("gzip", Just 1.0), ("identity",Just 0.5), ("*", Just 0)]) + , (" x-gzip",[("x-gzip", Nothing)]) + ] + +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" ~: + [ uncompressedResponse + , uncompressedSendFile + , compressedResponseGZ + , compressedResponseZ + , compressedSendFile + , compressedSendFileNoIdentity + ] + +mkRequest :: Method -> String -> [(String, Cookie)] -> Headers -> L.ByteString -> IO Request +mkRequest method uri cookies headers body = + do let u = toSURI uri + ib <- newEmptyMVar + b <- newMVar (Body body) + return $ Request { rqMethod = method + , rqPaths = (pathEls (path u)) + , rqUri = (path u) + , rqQuery = (query u) + , rqInputsQuery = (queryInput u) + , rqInputsBody = ib + , rqCookies = cookies + , rqVersion = HttpVersion 1 1 + , rqHeaders = headers + , rqBody = b + , rqPeer = ("",0) + , rqSecure = False + } + +compressPart :: ServerPart Response +compressPart = + do void compressedResponseFilter + composeFilter noContentLength + msum [ dir "response" $ ok (toResponse "compress Response") + , dir "sendfile" $ ok (sendFileResponse "text/plain" "/dev/null" Nothing 0 100) + ] + +cookieHeaderOrderTestHandler :: ServerPart Response +cookieHeaderOrderTestHandler = do + expireCookie "thecookie" + addCookie Session $ mkCookie "thecookie" "value" + ok $ toResponse $ "works" + +cookieHeaderOrderTest :: Test +cookieHeaderOrderTest = + "cookie header order test" ~: + do req <- mkRequest GET "/" [] Map.empty L.empty + res <- simpleHTTP'' cookieHeaderOrderTestHandler req + let Just pair = (Map.lookup (B.pack "set-cookie") (rsHeaders res)) + assertEqual "Add cookie wins" False $ B.isInfixOf (B.pack "Max-Age=0") + (last $ hValue pair) + +uncompressedResponse :: Test +uncompressedResponse = + "uncompressedResponse" ~: + do req <- mkRequest GET "/response" [] Map.empty L.empty + res <- simpleHTTP'' compressPart req + assertEqual "respone code" (rsCode res) 200 + assertEqual "body" (unpack (rsBody res)) "compress Response" + assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing + +uncompressedSendFile :: Test +uncompressedSendFile = + "uncompressedSendFile" ~: + do req <- mkRequest GET "/sendfile" [] Map.empty L.empty + res <- simpleHTTP'' compressPart req + assertEqual "respone code" (rsCode res) 200 + assertEqual "filepath" (sfFilePath res) "/dev/null" + assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing + +compressedResponseGZ :: Test +compressedResponseGZ = + "compressedResponseGZ" ~: + do req <- mkRequest GET "/response" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1"])) L.empty + res <- simpleHTTP'' compressPart req + assertEqual "respone code" (rsCode res) 200 + assertEqual "body" (unpack (GZ.decompress (rsBody res))) ("compress Response") + assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) (Just (B.pack "Content-Encoding", [B.pack "gzip"])) + +compressedResponseZ :: Test +compressedResponseZ = + "compressedResponseZ" ~: + do req <- mkRequest GET "/response" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " deflate;q=1"])) L.empty + res <- simpleHTTP'' compressPart req + assertEqual "respone code" (rsCode res) 200 + assertEqual "body" (unpack (Z.decompress (rsBody res))) ("compress Response") + assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) (Just (B.pack "Content-Encoding", [B.pack "deflate"])) + +compressedSendFile :: Test +compressedSendFile = + "compressedSendfile" ~: + do req <- mkRequest GET "/sendfile" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1"])) L.empty + res <- simpleHTTP'' compressPart req + assertEqual "respone code" (rsCode res) 200 + assertEqual "filepath" (sfFilePath res) "/dev/null" + assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing + +compressedSendFileNoIdentity :: Test +compressedSendFileNoIdentity = + "compressedSendFileNoIdentity" ~: + do req <- mkRequest GET "/sendfile" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1, identity: q=0.0"])) L.empty + res <- simpleHTTP'' compressPart req + assertEqual "respone code" (rsCode res) 406 + assertEqual "body" (unpack (rsBody res)) "" + assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing + +matchMethodTest :: Test +matchMethodTest = + "matchMethodTest" ~: + do forM_ gethead $ \m -> matchMethod GET m @?= True + forM_ others $ \m -> matchMethod GET m @?= False + forM_ gethead $ \m -> matchMethod [GET] m @?= True + forM_ others $ \m -> matchMethod [GET] m @?= False + forM_ gethead $ \m -> matchMethod [GET, HEAD] m @?= True + forM_ others $ \m -> matchMethod [GET, HEAD] m @?= False + matchMethod POST GET @?= False + matchMethod POST HEAD @?= False + matchMethod POST TRACE @?= False + matchMethod POST POST @?= True + matchMethod [POST, PUT] GET @?= False + matchMethod [POST, PUT] HEAD @?= False + matchMethod [POST, PUT] TRACE @?= False + matchMethod [POST, PUT] POST @?= True + matchMethod [POST, PUT] PUT @?= True + forM_ (others) $ \m -> matchMethod (`notElem` gethead) m @?= True + forM_ (gethead ++ others) $ \m -> matchMethod () m @?= True + where + gethead = [GET, HEAD] + others = [POST, PUT, DELETE, TRACE, OPTIONS, CONNECT] + + +-- | https://github.com/Happstack/happstack-server/pull/56 +pContentDispositionFilename :: Test +pContentDispositionFilename = + "pContentDispositionFilename" ~: + do let doesNotWorkWithOldParserButWithNew = "form-data; filename=\"file.pdf\"; name=\"file\"" :: String + c <- parseContentDisposition doesNotWorkWithOldParserButWithNew + assertEqual "parseContentDisposition" c (ContentDisposition "form-data" [("filename","file.pdf"),("name","file")]) + +applicativeTest :: Test +applicativeTest = + "applicativeTest" ~: + do req <- mkRequest GET "/response" [] mempty L.empty + res <- flip simpleHTTP'' req $ do + Left errors <- getDataFn $ (++) <$> look "a" <*> look "b" + pure $ intercalate "," errors + let ref = "Parameter not found: a,Parameter not found: b" + assertEqual "getDataFn/ReaderError doesn't short-circuit" ref (unpack (rsBody res))