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.3.9 +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,30 +9,40 @@ homepage: http://happstack.com Category: Web, Happstack Build-Type: Simple -Cabal-Version: >= 1.8 -Extra-Source-Files: tests/Happstack/Server/Tests.hs +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 template_haskell - Description: Template Haskell is available on this system - Default: True - Manual: True +source-repository head + type: git + location: https://github.com/Happstack/happstack-server.git 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 @@ -46,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 @@ -63,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 if flag(network-uri) - build-depends: network > 2.6 && < 2.7, + 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.*, - blaze-html >= 0.5 && < 0.8, + 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.3, - old-locale, - 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 && < 1.3, - time, - time-compat, - threads >= 0.5, - transformers >= 0.1.3 && < 0.5, - 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(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,19 +54,18 @@ isDot ) where -import Control.Applicative ((<$>)) 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) -import Data.Time.Compat (toUTCTime) +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) @@ -74,7 +73,6 @@ 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 Text.Blaze.Html ((!)) import qualified Text.Blaze.Html5 as H @@ -99,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 -- @@ -124,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"] @@ -133,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 @@ -214,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 -- @@ -231,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 -- @@ -247,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 @@ -526,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 -- @@ -609,7 +609,7 @@ -> IO (FilePath, Maybe UTCTime, Maybe Integer, EntryKind) getMetaData localPath fp = do let localFp = localPath fp - modTime <- (Just . toUTCTime <$> getModificationTime localFp) `E.catch` + modTime <- (Just <$> getModificationTime localFp) `E.catch` (\(_ :: IOException) -> return Nothing) count <- do de <- doesDirectoryExist localFp if de @@ -628,7 +628,7 @@ -- | 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'. -- @@ -711,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 @@ -8,6 +8,7 @@ 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 @@ -56,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) @@ -76,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) @@ -85,7 +88,9 @@ let ioseq act = act >>= \x -> x `seq` return x (res, handlerKilled) <- ((, False) `liftM` ioseq (handler req)) - `E.catch` \(e::E.SomeException) -> return (failResponse (show e), fromException e == Just ThreadKilled) + `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 () @@ -106,8 +111,13 @@ cleanupTempFiles req -- do not continue if handler was killed when (not handlerKilled && continueHTTP req res) $ - rloop timeoutIO mlog host handler nextRequest + 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 = @@ -131,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,_) <- @@ -194,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,6 +1,7 @@ {-# 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) @@ -10,15 +11,10 @@ import Control.Exception.Extensible as E import Control.Concurrent (forkIO, killThread, myThreadId) import Control.Monad -import Network.BSD (getProtocolNumber) -import Network (Socket) -import Network.Socket as Socket (SocketOption(KeepAlive), close, 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) - (close) + (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) - (close) + (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 lsocket <- listenOn port' - setSocketOption lsocket KeepAlive 1 + 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 - close 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` (close s >> forceTimeoutAll tm) + 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 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,23 +1,34 @@ -{-# 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 qualified Control.Monad.RWS.Lazy as Lazy ( RWST, mapRWST ) import qualified Control.Monad.RWS.Strict as Strict ( RWST, mapRWST ) +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 ) @@ -34,15 +45,24 @@ 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 @@ -56,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 @@ -66,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'. @@ -151,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 @@ -201,6 +234,37 @@ askRq = ServerPartT $ ask localRq f m = ServerPartT $ local f (unServerPartT m) +-- | 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 @@ -218,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,6 +317,12 @@ 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 @@ -259,14 +331,14 @@ {-# INLINE liftIO #-} instance MonadTransControl (FilterT a) where - newtype StT (FilterT a) b = StFilter {unStFilter :: StT (Lazy.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. -- @@ -301,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 @@ -312,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 @@ -386,8 +464,13 @@ {-# INLINE (>>=) #-} return a = WebT $ return a {-# INLINE return #-} - fail s = lift (fail 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 @@ -422,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 @@ -430,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 . Lazy.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 . Lazy.WriterT . MaybeT +mkWebT = WebT . ExceptT . FilterT . Lazy.WriterT . MaybeT -- | See 'mapServerPartT' for a discussion of this function. mapWebT :: (UnWebT m a -> UnWebT n b) @@ -497,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" #-} @@ -670,6 +756,7 @@ -- 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 @@ -686,3 +773,28 @@ 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,7 +1,4 @@ {-# LANGUAGE CPP #-} -#ifdef TEMPLATE_HASKELL -{-# LANGUAGE TemplateHaskell #-} -#endif module Happstack.Server.Internal.Socket ( acceptLite , sockAddrToPeer @@ -9,13 +6,8 @@ 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.Socket as S - ( Socket(..) + ( Socket , PortNumber() , SockAddr(..) , HostName @@ -57,44 +49,7 @@ sockAddrToPeer :: S.SockAddr -> (S.HostName, S.PortNumber) sockAddrToPeer addr = -#ifdef TEMPLATE_HASKELL - $(if supportsIPv6 - then - return $ CaseE (VarE (mkName "addr")) - [ Match - (ConP (mkName "S.SockAddrInet") - [VarP (mkName "p"),VarP (mkName "ha")]) - (NormalB - (TupE - [(AppE (VarE (mkName "showHostAddress")) - (VarE (mkName "ha"))) - , VarE (mkName "p") - ])) [] - , Match (ConP (mkName "S.SockAddrInet6") - [VarP (mkName "p"),WildP,VarP (mkName "ha"),WildP]) - (NormalB - (TupE - [ (AppE - (VarE (mkName "showHostAddress6")) - (VarE (mkName "ha"))) - , VarE (mkName "p") - ])) [] - , Match WildP - (NormalB (AppE (VarE (mkName "error")) - (LitE (StringL "Unsupported socket")))) []] - -- the above mess is the equivalent of this: - {-[| case addr of - (S.SockAddrInet p ha) -> (showHostAddress ha, p) - (S.SockAddrInet6 p _ ha _ ) -> (showHostAddress6 ha, p) - _ -> error "Unsupported socket" - |]-} - else - [| case addr of - (S.SockAddrInet p ha) -> (showHostAddress ha, p) - _ -> error "Unsupported socket" - |]) -#else - case addr of - (S.SockAddrInet p ha) -> (showHostAddress ha, p) - _ -> error "Unsupported socket" -#endif + 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/TimeoutSocket.hs b/src/Happstack/Server/Internal/TimeoutSocket.hs --- a/src/Happstack/Server/Internal/TimeoutSocket.hs +++ b/src/Happstack/Server/Internal/TimeoutSocket.hs @@ -4,6 +4,7 @@ -} module Happstack.Server.Internal.TimeoutSocket where +import Control.Applicative (pure) import Control.Concurrent (threadWaitWrite) import Control.Exception as E (catch, throw) import Control.Monad (liftM, when) @@ -11,7 +12,7 @@ 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(..)) @@ -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 @@ -77,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 @@ -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,31 +224,35 @@ , 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 @@ -247,7 +268,7 @@ , rqHeaders :: Headers -- ^ the HTTP request headers , rqBody :: MVar RqBody -- ^ the raw, undecoded request body , rqPeer :: Host -- ^ (hostname, port) of the client making the request - } deriving (Typeable) + } instance Show Request where showsPrec _ rq = @@ -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. @@ -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. -- @@ -35,12 +35,17 @@ -- * MonadPlus helpers , require , requireM + -- * escapeHTTP + , escapeHTTP ) where import Control.Applicative (Alternative, Applicative) import Control.Monad (MonadPlus(mzero)) -import Control.Monad.Error (Error, ErrorT) +#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 qualified Control.Monad.Writer.Lazy as Lazy (WriterT) import qualified Control.Monad.Writer.Strict as Strict (WriterT) @@ -68,7 +73,10 @@ 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) @@ -107,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) +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 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 @@ -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,5 +1,5 @@ {-# 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: +-- | 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 @@ -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) 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,9 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} +{-# 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 ( -- * Looking up keys -- ** Form Values and Query Parameters @@ -58,9 +58,8 @@ , 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 qualified Control.Monad.State.Lazy as Lazy (StateT, mapStateT) import qualified Control.Monad.State.Strict as Strict (StateT, mapStateT) @@ -68,39 +67,62 @@ 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) -import Control.Monad.Error (Error(noMsg, strMsg), ErrorT, mapErrorT) +#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 $ \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) @@ -112,17 +134,37 @@ -- | 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 +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 ()) @@ -156,33 +198,10 @@ 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, RWST, and ErrorT @@ -223,11 +242,18 @@ localRqEnv f = Strict.mapRWST (localRqEnv f) rqDataError e = lift (rqDataError e) -instance (Monad m, Error e, HasRqData m) => HasRqData (ErrorT e m) where +#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 = mapErrorT (localRqEnv f) + 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' @@ -278,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 @@ -466,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 @@ -555,11 +582,11 @@ 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 +-- | 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: -- @@ -607,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 @@ -619,7 +646,7 @@ -- 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 @@ -649,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 @@ -23,7 +23,7 @@ import Control.Arrow (first) import Data.Char (chr, digitToInt, isHexDigit) import Data.Maybe (fromJust, isJust) -import Data.Generics (Data, Typeable) +import Data.Generics (Data) import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import qualified Network.URI as URI @@ -74,7 +74,7 @@ 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 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 @@ -30,9 +30,9 @@ -- > 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,7 +75,6 @@ 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 @@ -87,7 +85,7 @@ 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) diff --git a/tests/Happstack/Server/Tests.hs b/tests/Happstack/Server/Tests.hs --- a/tests/Happstack/Server/Tests.hs +++ b/tests/Happstack/Server/Tests.hs @@ -10,15 +10,18 @@ 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) + , 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 @@ -32,6 +35,8 @@ , compressFilterResponseTest , matchMethodTest , cookieHeaderOrderTest + , pContentDispositionFilename + , applicativeTest ] cookieParserTest :: Test @@ -39,24 +44,24 @@ "cookieParserTest" ~: [parseCookies "$Version=1;Cookie1=value1;$Path=\"/testpath\";$Domain=example.com;cookie2=value2" @?= (Right [ - Cookie "1" "/testpath" "example.com" "cookie1" "value1" False False - , Cookie "1" "" "" "cookie2" "value2" False False + 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 + Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/|" False False SameSiteNoValue False ]) ,parseCookies " cookie1 = value1 " @?= (Right [ - Cookie "" "" "" "cookie1" "value1" False False + Cookie "" "" "" "cookie1" "value1" False False SameSiteNoValue False ]) ,parseCookies " $Version=\"1\";buggygooglecookie = valuewith=whereitshouldnotbe " @?= (Right [ - Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" False False + Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" False False SameSiteNoValue False ]) , parseCookies "foo=\"\\\"bar\\\"\"" @?= (Right [ - Cookie "" "" "" "foo" "\"bar\"" False False + Cookie "" "" "" "foo" "\"bar\"" False False SameSiteNoValue False ]) ] @@ -236,3 +241,22 @@ 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))