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/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,3 @@ #!/usr/bin/env runhaskell import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks +main = defaultMainWithHooks simpleUserHooks diff --git a/happstack-server.cabal b/happstack-server.cabal --- a/happstack-server.cabal +++ b/happstack-server.cabal @@ -1,108 +1,147 @@ Name: happstack-server -Version: 0.2.1 +Version: 7.9.3 Synopsis: Web related tools and services. -Description: Web framework +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 License-file: COPYING Author: Happstack team, HAppS LLC Maintainer: Happstack team homepage: http://happstack.com -Category: Web, Distributed Computing +Category: Web, Happstack Build-Type: Simple -Cabal-Version: >= 1.4 +Cabal-Version: >= 1.10 +Extra-Source-Files: tests/Happstack/Server/Tests.hs README.md -Flag base4 - Description: Choose the even newer, even smaller, split-up base package. +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 tests - Description: Build the testsuite, and include the tests in the library - Default: False +source-repository head + type: git + location: https://github.com/Happstack/happstack-server.git -Library +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.HTTP.Client - Happstack.Server.HTTP.Types - Happstack.Server.HTTP.LowLevel - Happstack.Server.HTTP.FileServe - Happstack.Server.SimpleHTTP - Happstack.Server.JSON - Happstack.Server.MessageWrap - Happstack.Server.MinHaXML + Happstack.Server.Compression + Happstack.Server.Error + Happstack.Server.FileServe + Happstack.Server.FileServe.BuildingBlocks + Happstack.Server.I18N + Happstack.Server.Internal.Compression + Happstack.Server.Internal.Cookie + Happstack.Server.Internal.Handler + Happstack.Server.Internal.Types + Happstack.Server.Internal.Listen + Happstack.Server.Internal.LowLevel + Happstack.Server.Internal.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.Response + Happstack.Server.Routing + Happstack.Server.RqData Happstack.Server.SURI - Happstack.Server.XSLT - Happstack.Server.StdConfig - Happstack.Server.Parts - if flag(tests) - Exposed-modules: - Happstack.Server.Tests - Other-modules: - Happstack.Server.S3 - Happstack.Server.HTTPClient.HTTP - Happstack.Server.HTTPClient.Stream - Happstack.Server.HTTPClient.TCP - Happstack.Server.HTTP.Clock - Happstack.Server.HTTP.Handler - Happstack.Server.HTTP.LazyLiner - Happstack.Server.HTTP.Listen - Happstack.Server.HTTP.Multipart - Happstack.Server.HTTP.RFC822Headers - Happstack.Server.HTTP.Socket - Happstack.Server.HTTP.SocketTH + Happstack.Server.SimpleHTTP + Happstack.Server.Types + Happstack.Server.Validation + Other-modules: + Happstack.Server.Internal.Clock + Happstack.Server.Internal.LazyLiner Happstack.Server.SURI.ParseURI Paths_happstack_server - Build-Depends: base, + if flag(network-uri) + build-depends: network >= 3.0.0 && < 3.3, + network-uri >= 2.6 && < 2.7 + else + build-depends: network < 2.6 + Build-Depends: base >= 4 && < 5, + base64-bytestring >= 1.0 && < 1.3, + blaze-html >= 0.5 && < 0.10, bytestring, containers, - directory, + directory >=1.2, + exceptions, extensible-exceptions, - HaXml >= 1.13 && < 1.14, - hslogger >= 1.0.2, - happstack-data >= 0.2.1 && < 0.3, - happstack-util >= 0.2.1 && < 0.3, + filepath, + hslogger >= 1.0.2, html, - MaybeT, - mtl, - network, - old-locale, - old-time, - parsec < 3, + monad-control >= 1.0 && < 1.1, + mtl >= 2.2 && < 2.4, + parsec < 4, process, - template-haskell, - time, - xhtml, + sendfile >= 0.7.1 && < 0.8, + system-filepath >= 0.3.1, + syb, + 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 hs-source-dirs: src - if flag(tests) - hs-source-dirs: tests if !os(windows) Build-Depends: unix cpp-options: -DUNIX - if flag(base4) - Build-Depends: base >= 4 && < 5, syb - if flag(tests) - Build-Depends: HUnit + if impl(ghc < 8.6) + Default-Extensions: MonadFailDesugaring - Extensions: TemplateHaskell, DeriveDataTypeable, MultiParamTypeClasses, - TypeFamilies, FlexibleContexts, OverlappingInstances, - FlexibleInstances, UndecidableInstances, ScopedTypeVariables, - TypeSynonymInstances, PatternGuards + Other-Extensions: DeriveDataTypeable, MultiParamTypeClasses, + TypeFamilies, FlexibleContexts, + FlexibleInstances, UndecidableInstances, + ScopedTypeVariables, TypeSynonymInstances, PatternGuards CPP, ForeignFunctionInterface - ghc-options: -Wall - GHC-Prof-Options: -auto-all + ghc-options: -Wall -fwarn-tabs + -- 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 < 8.0) + buildable: False -Executable happstack-server-tests +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 - Build-depends: HUnit - hs-source-dirs: tests, src - if flag(tests) - Buildable: True - else - Buildable: False + hs-source-dirs: tests + Build-depends: HUnit, + 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 @@ -1,15 +1,91 @@ -module Happstack.Server -(module Happstack.Server.XSLT -,module Happstack.Server.SimpleHTTP -,module Happstack.Server.HTTP.Client -,module Happstack.Server.MessageWrap -,module Happstack.Server.HTTP.FileServe -,module Happstack.Server.StdConfig) -where -import Happstack.Server.HTTP.Client -import Happstack.Server.StdConfig -import Happstack.Server.XSLT -import Happstack.Server.SimpleHTTP -import Happstack.Server.MessageWrap -import Happstack.Server.HTTP.FileServe +{- | +Module : Happstack.Server +Copyright : (c) Happstack.com 2010; (c) HAppS Inc 2007 +License : BSD3 +Maintainer : Happstack team +Stability : provisional +Portability : GHC-only, Windows, Linux, FreeBSD, OS X + +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!" + +By default the server will listen on port 8000. Run the app and point your browser at: + +At the core of the Happstack server we have the 'simpleHTTP' function which starts the HTTP server: + +> simpleHTTP :: ToMessage a => Conf -> ServerPart a -> IO () + +and we have the user supplied 'ServerPart' (also known as, +'ServerPartT' 'IO'), which generates a 'Response' for each incoming +'Request'. + +A trivial HTTP app server might just take a user supplied function like: + +> myApp :: Request -> IO Response + +For each incoming 'Request' the server would fork a new thread, run +@myApp@ to generate a 'Response', and then send the 'Response' back to +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. + +For in-depth documentation and runnable examples I highly recommend The Happstack Crash Course . + +-} +module Happstack.Server + ( -- * HTTP Server + module Happstack.Server.SimpleHTTP + -- * Request Routing + , module Happstack.Server.Routing + -- * Creating Responses + , module Happstack.Server.Response + -- * Looking up values in Query String, Request Body, and Cookies + , module Happstack.Server.RqData + -- * Create and Set Cookies (see also "Happstack.Server.RqData") + , module Happstack.Server.Cookie + -- * File Serving + , module Happstack.Server.FileServe + -- * HTTP Realm Authentication + , module Happstack.Server.Auth + -- * Error Handling + , module Happstack.Server.Error + -- * I18N + , module Happstack.Server.I18N + -- * Web-related Monads + , module Happstack.Server.Monads + -- * Output Validation + , module Happstack.Server.Validation + -- * HTTP Types + , module Happstack.Server.Types +-- , module Happstack.Server.Internal.Monads + ) + where + +import Happstack.Server.SimpleHTTP (simpleHTTP + , simpleHTTP' + , simpleHTTP'' + , simpleHTTPWithSocket + , simpleHTTPWithSocket' + , bindPort + , bindIPv4 + , parseConfig + , waitForTermination + ) +import Happstack.Server.FileServe +import Happstack.Server.Monads +import Happstack.Server.Auth +import Happstack.Server.Cookie +import Happstack.Server.Error +import Happstack.Server.I18N +import Happstack.Server.Response +import Happstack.Server.Routing +import Happstack.Server.RqData +import Happstack.Server.Validation +import Happstack.Server.Types +-- import Happstack.Server.Internal.Monads diff --git a/src/Happstack/Server/Auth.hs b/src/Happstack/Server/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Auth.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | 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) +import Happstack.Server.Response (unauthorized, toResponse) + +-- | A simple HTTP basic authentication guard. +-- +-- If authentication fails, this part will call 'mzero'. +-- +-- example: +-- +-- > main = simpleHTTP nullConf $ +-- > msum [ basicAuth "127.0.0.1" (fromList [("happstack","rocks")]) $ ok "You are in the secret club" +-- > , ok "You are not in the secret club." +-- > ] +-- +basicAuth :: (Happstack m) => + String -- ^ the realm name + -> M.Map String String -- ^ the username password map + -> m a -- ^ the part to guard + -> m a +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 (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 (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/Compression.hs b/src/Happstack/Server/Compression.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Compression.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-} +-- | 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 + , 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,138 +1,48 @@ -{-# LANGUAGE DeriveDataTypeable #-} - --- http://tools.ietf.org/html/rfc2109 +{-# 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 - , mkCookieHeader - , getCookies - , getCookie - , getCookies' - , getCookie' - , parseCookies - , cookiesParser + , addCookie + , addCookies + , expireCookie ) where -import qualified Data.ByteString.Char8 as C -import Data.Either -import Data.Char -import Data.List -import Data.Generics -import Happstack.Util.Common (Seconds) -import Text.ParserCombinators.Parsec hiding (token) - -data Cookie = Cookie - { cookieVersion :: String - , cookiePath :: String - , cookieDomain :: String - , cookieName :: String - , cookieValue :: String - } deriving(Show,Eq,Read,Typeable,Data) - --- | Creates a cookie with a default version of 1 and path of "/" -mkCookie :: String -> String -> Cookie -mkCookie key val = Cookie "1" "/" "" key val - --- | Set a Cookie in the Result. --- The values are escaped as per RFC 2109, but some browsers may --- have buggy support for cookies containing e.g. @\'\"\'@ or @\' \'@. -mkCookieHeader :: Seconds -> Cookie -> String -mkCookieHeader sec cookie = - let l = [("Domain=",s cookieDomain) - ,("Max-Age=",if sec < 0 then "" else show sec) - ,("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 ]) - -fctl :: Char -> Bool -fctl ch = ch == chr 127 || ch <= chr 31 - --- | Not an supported api. Takes a cookie header and returns --- either a String error message or an array of parsed cookies -parseCookies :: String -> Either String [Cookie] -parseCookies str = either (Left . show) Right $ parse cookiesParser str str - --- | not a supported api. A parser for RFC 2109 cookies -cookiesParser :: GenParser Char st [Cookie] -cookiesParser = cookies - where -- Parsers based on RFC 2109 - cookies = do - ws - ver<-option "" $ try (cookie_version >>= (\x -> cookieSep >> return x)) - cookieList<-(cookie_value ver) `sepBy1` try cookieSep - ws - eof - return cookieList - cookie_value ver = do - name<-attr - cookieEq - val<-value - path<-option "" $ try (cookieSep >> cookie_path) - domain<-option "" $ try (cookieSep >> cookie_domain) - return $ Cookie ver path domain (low name) val - cookie_version = cookie_special "$Version" - cookie_path = cookie_special "$Path" - cookie_domain = cookie_special "$Domain" - cookie_special s = do - string s - cookieEq - value - cookieSep = ws >> oneOf ",;" >> ws - cookieEq = ws >> char '=' >> ws - ws = spaces - attr = token - value = word - word = try (quoted_string) <|> incomp_token - - -- Parsers based on RFC 2068 - token = many1 $ oneOf ((chars \\ ctl) \\ tspecials) - quoted_string = do - char '"' - r <-many (oneOf qdtext) - char '"' - return r - - -- Custom parser, incompatible with RFC 2068, but very forgiving ;) - incomp_token = many1 $ oneOf ((chars \\ ctl) \\ " \t\";") - - -- Primitives from RFC 2068 - tspecials = "()<>@,;:\\\"/[]?={} \t" - ctl = map chr (127:[0..31]) - chars = map chr [0..127] - octet = map chr [0..255] - text = octet \\ ctl - qdtext = text \\ "\"" - --- | 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 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 s h = getCookie' s h >>= either (const $ fail ("getCookie: " ++ show s)) return +import Control.Monad.Trans (MonadIO(..)) +import Happstack.Server.Internal.Monads (FilterMonad, composeFilter) +import Happstack.Server.Internal.Cookie (Cookie(..), CookieLife(..), SameSite(..), calcLife, mkCookie, mkCookieHeader) +import Happstack.Server.Types (Response, addHeader) -getCookies' :: Monad m => C.ByteString -> m (Either String [Cookie]) -getCookies' header | C.null header = return $ Right [] - | otherwise = return $ parseCookies (C.unpack header) +-- | Add the 'Cookie' to 'Response'. +-- +-- example +-- +-- > main = simpleHTTP nullConf $ +-- > do addCookie Session (mkCookie "name" "value") +-- > ok $ "You now have a session cookie." +-- +-- see also: 'addCookies' +addCookie :: (MonadIO m, FilterMonad Response m) => CookieLife -> Cookie -> m () +addCookie life cookie = + do l <- liftIO $ calcLife life + (addHeaderM "Set-Cookie") $ mkCookieHeader l cookie + where + addHeaderM a v = composeFilter $ \res-> addHeader a v res -getCookie' :: Monad m => String -> C.ByteString -> m (Either String Cookie) -getCookie' s h = do - cs <- getCookies' h - return $ do -- Either - cooks <- cs - case filter (\x->(==) (low s) (cookieName x) ) cooks of - [] -> fail "No cookie found" - f -> return $ head f +-- | Add the list 'Cookie' to the 'Response'. +-- +-- see also: 'addCookie' +addCookies :: (MonadIO m, FilterMonad Response m) => [(CookieLife, Cookie)] -> m () +addCookies = mapM_ (uncurry addCookie) -low :: String -> String -low = map toLower +-- | Expire the named cookie immediately and set the cookie value to @\"\"@ +-- +-- > main = simpleHTTP nullConf $ +-- > do expireCookie "name" +-- > ok $ "The cookie has been expired." +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 new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Error.hs @@ -0,0 +1,57 @@ +-- | 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.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) +import Happstack.Server.Types (Request, Response) + +-------------------------------------------------------------- +-- Error Handling +-------------------------------------------------------------- + +-- | Flatten @'ServerPartT' ('ErrorT' e m) a@ into a @'ServerPartT' m +-- a@ so that it can be use with 'simpleHTTP'. Used with +-- 'mapServerPartT'', e.g., +-- +-- > simpleHTTP conf $ mapServerPartT' (spUnWrapErrorT simpleErrorHandler) $ myPart `catchError` errorPart +-- +-- Note that in this example, @simpleErrorHandler@ will only be run if @errorPart@ throws an error. You can replace @simpleErrorHandler@ with your own custom error handler. +-- +-- see also: 'simpleErrorHandler' +spUnwrapErrorT:: Monad m => (e -> ServerPartT m a) + -> Request + -> UnWebT (ExceptT e m) a + -> UnWebT m a +spUnwrapErrorT handler rq = \x -> do + err <- runExceptT x + case err of + Left e -> ununWebT $ runServerPartT (handler e) rq + Right a -> return a + +-- | A simple error handler which can be used with 'spUnwrapErrorT'. +-- +-- It returns the error message as a plain text message to the +-- browser. More sophisticated behaviour can be achieved by calling +-- your own custom error handler instead. +-- +-- see also: 'spUnwrapErrorT' +simpleErrorHandler :: (Monad m) => String -> ServerPartT m Response +simpleErrorHandler err = ok $ toResponse $ ("An error occured: " ++ err) + +-- | This 'ServerPart' modifier enables the use of 'throwError' and +-- 'catchError' inside the 'WebT' actions, by adding the 'ErrorT' +-- monad transformer to the stack. +-- +-- You can wrap the complete second argument to 'simpleHTTP' in this +-- function. +-- +-- DEPRECATED: use 'spUnwrapErrorT' instead. +errorHandlerSP :: (Monad m) => (Request -> e -> WebT m a) -> ServerPartT (ExceptT e m) a -> ServerPartT m a +errorHandlerSP handler sps = withRequest $ \req -> mkWebT $ do + eer <- runExceptT $ ununWebT $ runServerPartT sps req + case eer of + Left err -> ununWebT (handler req err) + Right res -> return res +{-# DEPRECATED errorHandlerSP "Use spUnwrapErrorT" #-} diff --git a/src/Happstack/Server/FileServe.hs b/src/Happstack/Server/FileServe.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/FileServe.hs @@ -0,0 +1,20 @@ +-- | functions for serving static files from the disk +module Happstack.Server.FileServe + ( -- * Serving Functions + Browsing(..) + , serveDirectory + , serveFile + , serveFileFrom + -- * Content-Type \/ Mime-Type + , MimeMap + , mimeTypes + , asContentType + , guessContentTypeM + -- * Index Files + , defaultIxFiles + -- * Deprecated + , fileServe + ) + where + +import Happstack.Server.FileServe.BuildingBlocks diff --git a/src/Happstack/Server/FileServe/BuildingBlocks.hs b/src/Happstack/Server/FileServe/BuildingBlocks.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/FileServe/BuildingBlocks.hs @@ -0,0 +1,716 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, ScopedTypeVariables, Rank2Types #-} +-- | Build your own file serving functions +-- +-- If the functions in "Happstack.Server.FileServe" do not quite do +-- you want you can roll your own by reusing pieces from this module. +-- +-- You will likely want to start by copying the source for a function +-- like, 'serveDirectory' and then modifying it to suit your needs. +-- +module Happstack.Server.FileServe.BuildingBlocks + ( + -- * High-Level + -- ** Serving files from a directory + fileServe, + fileServe', + fileServeLazy, + fileServeStrict, + Browsing(..), + serveDirectory, + serveDirectory', + -- ** Serving a single file + serveFile, + serveFileFrom, + serveFileUsing, + -- * Low-Level + sendFileResponse, + lazyByteStringResponse, + strictByteStringResponse, + filePathSendFile, + filePathLazy, + filePathStrict, + -- * Content-Type \/ Mime-Type + MimeMap, + mimeTypes, + asContentType, + guessContentType, + guessContentTypeM, + -- * Directory Browsing + EntryKind(..), + browseIndex, + renderDirectoryContents, + renderDirectoryContentsTable, + -- * Other + blockDotFiles, + defaultIxFiles, + combineSafe, + isSafePath, + tryIndex, + doIndex, + doIndex', + doIndexLazy, + doIndexStrict, + fileNotFound, + isDot + ) where + +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.Char (toLower) +import Data.Data (Data) +import Data.List (sort) +import Data.Maybe (fromMaybe) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Time (UTCTime, formatTime, defaultTimeLocale) +import Filesystem.Path.CurrentOS (commonPrefix, encodeString, decodeString, collapse, append) +import Happstack.Server.Monads (ServerMonad(askRq), FilterMonad, WebMonad) +import Happstack.Server.Response (ToMessage(toResponse), ifModifiedSince, forbidden, ok, seeOther) +import Happstack.Server.Types (Length(ContentLength), Request(rqPaths, rqUri), Response(SendFile), RsFlags(rsfLength), nullRsFlags, result, resultBS, setHeader) +import 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.Log.Logger (Priority(DEBUG), logM) +import Text.Blaze.Html ((!)) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A + +-- * Mime-Type / Content-Type + +-- |a 'Map' from file extensions to content-types +-- +-- example: +-- +-- > myMimeMap :: MimeMap +-- > myMimeMap = Map.fromList [("gz","application/x-gzip"), ... ] +-- +-- see also: 'mimeTypes' +type MimeMap = Map String String + +-- | try to guess the content-type of a file based on its extension +-- +-- see also: 'guessContentTypeM' +guessContentType :: MimeMap -> FilePath -> Maybe String +guessContentType mimeMap filepath = + case getExt filepath of + "" -> Nothing + 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 +-- +-- defaults to "application/octet-stream" if no match was found. +-- +-- Useful as an argument to 'serveFile' +-- +-- see also: 'guessContentType', 'serveFile' +guessContentTypeM :: (Monad m) => MimeMap -> (FilePath -> m String) +guessContentTypeM mimeMap filePath = return $ fromMaybe "application/octet-stream" $ guessContentType mimeMap filePath + +-- | returns a specific content type, completely ignoring the 'FilePath' argument. +-- +-- Use this with 'serveFile' if you want to explicitly specify the +-- content-type. +-- +-- see also: 'guessContentTypeM', 'serveFile' +asContentType :: (Monad m) => + String -- ^ the content-type to return + -> (FilePath -> m String) +asContentType = const . return + +-- | a list of common index files. Specifically: @index.html@, @index.xml@, @index.gif@ +-- +-- Typically used as an argumebnt to 'serveDiretory'. +defaultIxFiles :: [FilePath] +defaultIxFiles= ["index.html","index.xml","index.gif"] + +-- | return a simple "File not found 404 page." +fileNotFound :: (Monad m, FilterMonad Response m) => FilePath -> m Response +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 + +-- | Prevents files of the form '.foo' or 'bar/.foo' from being served +blockDotFiles :: (Request -> IO Response) -> Request -> IO Response +blockDotFiles fn rq + | isDot (joinPath (rqPaths rq)) = return $ result 403 "Dot files not allowed." + | otherwise = fn rq + +-- | Returns True if the given String either starts with a . or is of the form +-- "foo/.bar", e.g. the typical *nix convention for hidden files. +isDot :: String -> Bool +isDot = isD . reverse + where + isD ('.':'/':_) = True + isD ['.'] = True + --isD ('/':_) = False + isD (_:cs) = isD cs + isD [] = False + +-- * Low-level functions for generating a Response + +-- | Use sendFile to send the contents of a Handle +sendFileResponse :: String -- ^ content-type string + -> FilePath -- ^ file path for content to send + -> Maybe (UTCTime, Request) -- ^ mod-time for the handle (MUST NOT be later than server's time of message origination), incoming request (used to check for if-modified-since header) + -> Integer -- ^ offset into Handle + -> Integer -- ^ number of bytes to send + -> Response +sendFileResponse ct filePath mModTime offset count = + let res = ((setHeader "Content-Type" ct) $ + (SendFile 200 Map.empty (nullRsFlags { rsfLength = ContentLength }) Nothing filePath offset count) + ) + in case mModTime of + Nothing -> res + (Just (modTime, request)) -> ifModifiedSince modTime request res + +-- | Send the contents of a Lazy ByteString +-- +lazyByteStringResponse :: String -- ^ content-type string (e.g. @\"text/plain; charset=utf-8\"@) + -> L.ByteString -- ^ lazy bytestring content to send + -> Maybe (UTCTime, Request) -- ^ mod-time for the bytestring, incoming request (used to check for if-modified-since header) + -> Integer -- ^ offset into the bytestring + -> Integer -- ^ number of bytes to send (offset + count must be less than or equal to the length of the bytestring) + -> Response +lazyByteStringResponse ct body mModTime offset count = + let res = ((setHeader "Content-Type" ct) $ + resultBS 200 (L.take (fromInteger count) $ (L.drop (fromInteger offset)) body) + ) + in case mModTime of + Nothing -> res + (Just (modTime, request)) -> ifModifiedSince modTime request res + +-- | Send the contents of a Lazy ByteString +strictByteStringResponse :: String -- ^ content-type string (e.g. @\"text/plain; charset=utf-8\"@) + -> S.ByteString -- ^ lazy bytestring content to send + -> Maybe (UTCTime, Request) -- ^ mod-time for the bytestring, incoming request (used to check for if-modified-since header) + -> Integer -- ^ offset into the bytestring + -> Integer -- ^ number of bytes to send (offset + count must be less than or equal to the length of the bytestring) + -> Response +strictByteStringResponse ct body mModTime offset count = + let res = ((setHeader "Content-Type" ct) $ + resultBS 200 (L.fromChunks [S.take (fromInteger count) $ S.drop (fromInteger offset) body]) + ) + in case mModTime of + Nothing -> res + (Just (modTime, request)) -> ifModifiedSince modTime request res + +-- | Send the specified file with the specified mime-type using sendFile() +-- +-- NOTE: assumes file exists and is readable by the server. See 'serveFileUsing'. +-- +-- WARNING: No security checks are performed. +filePathSendFile :: (ServerMonad m, MonadIO m) + => String -- ^ content-type string + -> FilePath -- ^ path to file on disk + -> m Response +filePathSendFile contentType fp = + do count <- liftIO $ withBinaryFile fp ReadMode hFileSize -- garbage collection should close this + modtime <- liftIO $ getModificationTime fp + rq <- askRq + return $ sendFileResponse contentType fp (Just (modtime, rq)) 0 count + +-- | Send the specified file with the specified mime-type using lazy ByteStrings +-- +-- NOTE: assumes file exists and is readable by the server. See 'serveFileUsing'. +-- +-- WARNING: No security checks are performed. +filePathLazy :: (ServerMonad m, MonadIO m) + => String -- ^ content-type string + -> FilePath -- ^ path to file on disk + -> m Response +filePathLazy contentType fp = + do handle <- liftIO $ openBinaryFile fp ReadMode -- garbage collection should close this + contents <- liftIO $ L.hGetContents handle + modtime <- liftIO $ getModificationTime fp + count <- liftIO $ hFileSize handle + rq <- askRq + return $ lazyByteStringResponse contentType contents (Just (modtime, rq)) 0 count + +-- | Send the specified file with the specified mime-type using strict ByteStrings +-- +-- NOTE: assumes file exists and is readable by the server. See 'serveFileUsing'. +-- +-- WARNING: No security checks are performed. +filePathStrict :: (ServerMonad m, MonadIO m) + => String -- ^ content-type string + -> FilePath -- ^ path to file on disk + -> m Response +filePathStrict contentType fp = + do contents <- liftIO $ S.readFile fp + modtime <- liftIO $ getModificationTime fp + count <- liftIO $ withBinaryFile fp ReadMode hFileSize + rq <- askRq + return $ strictByteStringResponse contentType contents (Just (modtime, rq)) 0 count + +-- * High-level functions for serving files + + +-- ** Serve a single file + +-- | Serve a single, specified file. The name of the file being served is specified explicity. It is not derived automatically from the 'Request' url. +-- +-- example 1: +-- +-- Serve using sendfile() and the specified content-type +-- +-- > serveFileUsing filePathSendFile (asContentType "image/jpeg") "/srv/data/image.jpg" +-- +-- +-- example 2: +-- +-- Serve using a lazy ByteString and the guess the content-type from the extension +-- +-- > serveFileUsing filePathLazy (guessContentTypeM mimeTypes) "/srv/data/image.jpg" +-- +-- WARNING: No security checks are performed. +serveFileUsing :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) + => (String -> FilePath -> m Response) -- ^ typically 'filePathSendFile', 'filePathLazy', or 'filePathStrict' + -> (FilePath -> m String) -- ^ function for determining content-type of file. Typically 'asContentType' or 'guessContentTypeM' + -> FilePath -- ^ path to the file to serve + -> m Response +serveFileUsing serveFn mimeFn fp = + do fe <- liftIO $ doesFileExist fp + if fe + then do mt <- mimeFn fp + serveFn mt fp + else mzero + +-- | Serve a single, specified file. The name of the file being served is specified explicity. It is not derived automatically from the 'Request' url. +-- +-- example 1: +-- +-- Serve as a specific content-type: +-- +-- > serveFile (asContentType "image/jpeg") "/srv/data/image.jpg" +-- +-- +-- example 2: +-- +-- Serve guessing the content-type from the extension: +-- +-- > serveFile (guessContentTypeM mimeTypes) "/srv/data/image.jpg" +-- +-- If the specified path does not exist or is not a file, this function will return 'mzero'. +-- +-- WARNING: No security checks are performed. +-- +-- NOTE: alias for 'serveFileUsing' 'filePathSendFile' +serveFile :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => + (FilePath -> m String) -- ^ function for determining content-type of file. Typically 'asContentType' or 'guessContentTypeM' + -> FilePath -- ^ path to the file to serve + -> m Response +serveFile = serveFileUsing filePathSendFile + +-- | Like 'serveFile', but uses 'combineSafe' to prevent directory +-- traversal attacks when the path to the file is supplied by the user. +serveFileFrom :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => + FilePath -- ^ directory wherein served files must be contained + -> (FilePath -> m String) -- ^ function for determining content-type of file. Typically 'asContentType' or 'guessContentTypeM' + -> FilePath -- ^ path to the file to serve + -> m Response +serveFileFrom root mimeFn fp = + maybe no yes $ combineSafe root fp + where + no = forbidden $ toResponse "Directory traversal forbidden" + yes = serveFile mimeFn + +-- ** Serve files from a directory + +-- | Serve files from a directory and its subdirectories (parameterizable version) +-- +-- Parameterize this function to create functions like, 'fileServe', 'fileServeLazy', and 'fileServeStrict' +-- +-- You supply: +-- +-- 1. a low-level function which takes a content-type and 'FilePath' and generates a Response +-- +-- 2. a function which determines the content-type from the 'FilePath' +-- +-- 3. a list of all the default index files +-- +-- NOTE: unlike fileServe, there are no index files by default. See 'defaultIxFiles'. +fileServe' :: ( WebMonad Response m + , ServerMonad m + , FilterMonad Response m + , MonadIO m + , MonadPlus m + ) + => (String -> FilePath -> m Response) -- ^ function which takes a content-type and filepath and generates a response (typically 'filePathSendFile', 'filePathLazy', or 'filePathStrict') + -> (FilePath -> m String) -- ^ function which returns the mime-type for FilePath +-- -> [FilePath] -- ^ index file names, in case the requested path is a directory + -> (FilePath -> m Response) + -> FilePath -- ^ file/directory to serve + -> m Response +fileServe' serveFn mimeFn indexFn localPath = do + rq <- askRq + if (not $ isSafePath (rqPaths rq)) + then do liftIO $ logM "Happstack.Server.FileServe" DEBUG ("fileServe: unsafe filepath " ++ show (rqPaths rq)) + mzero + else do let fp = joinPath (localPath : rqPaths rq) + fe <- liftIO $ doesFileExist fp + de <- liftIO $ doesDirectoryExist fp + let status | de = "DIR" + | fe = "file" + | True = "NOT FOUND" + liftIO $ logM "Happstack.Server.FileServe" DEBUG ("fileServe: "++show fp++" \t"++status) + if de + then if last (rqUri rq) == '/' + then indexFn fp + else do let path' = addTrailingPathSeparator (rqUri rq) + seeOther path' (toResponse path') + else if fe + then serveFileUsing serveFn mimeFn fp + else mzero + +-- | Combine two 'FilePath's, ensuring that the resulting path leads to +-- a file within the first 'FilePath'. +-- +-- >>> combineSafe "/var/uploads/" "etc/passwd" +-- Just "/var/uploads/etc/passwd" +-- >>> combineSafe "/var/uploads/" "/etc/passwd" +-- Nothing +-- >>> combineSafe "/var/uploads/" "../../etc/passwd" +-- Nothing +-- >>> combineSafe "/var/uploads/" "../uploads/home/../etc/passwd" +-- Just "/var/uploads/etc/passwd" +combineSafe :: FilePath -> FilePath -> Maybe FilePath +combineSafe root path = + if commonPrefix [root', joined] == root' + then Just $ encodeString joined + else Nothing + where + root' = decodeString root + path' = decodeString path + joined = collapse $ append root' path' + +isSafePath :: [FilePath] -> Bool +isSafePath [] = True +isSafePath (s:ss) = + isValid s + && (all (not . isPathSeparator) s) + && not (hasDrive s) + && not (isParent s) + && isSafePath ss + +-- note: could be different on other OSs +isParent :: FilePath -> Bool +isParent ".." = True +isParent _ = False + +-- | Serve files from a directory and its subdirectories using 'sendFile'. +-- +-- Usage: +-- +-- > fileServe ["index.html"] "path/to/files/on/disk" +-- +-- 'fileServe' does not support directory browsing. See 'serveDirectory' +-- +-- DEPRECATED: use 'serveDirectory' instead. +-- +-- Note: +-- +-- The list of index files @[\"index.html\"]@ is only used to determine what file to show if the user requests a directory. You *do not* need to explicitly list all the files you want to serve. +-- +fileServe :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => + [FilePath] -- ^ index file names, in case the requested path is a directory + -> FilePath -- ^ file/directory to serve + -> m Response +fileServe ixFiles localPath = + fileServe' serveFn mimeFn indexFn localPath + where + serveFn = filePathSendFile + mimeFn = guessContentTypeM mimeTypes + indexFiles = (ixFiles ++ defaultIxFiles) + indexFn = doIndex' filePathSendFile mimeFn indexFiles +-- indexFn = browseIndex filePathSendFile mimeFn indexFiles +{-# DEPRECATED fileServe "use serveDirectory instead." #-} + +-- | Serve files from a directory and its subdirectories (lazy ByteString version). +-- +-- WARNING: May leak file handles. You should probably use 'fileServe' instead. +fileServeLazy :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => + [FilePath] -- ^ index file names, in case the requested path is a directory + -> FilePath -- ^ file/directory to serve + -> m Response +fileServeLazy ixFiles localPath = + fileServe' serveFn mimeFn indexFn localPath + where + serveFn = filePathLazy + mimeFn = guessContentTypeM mimeTypes + indexFiles = (ixFiles ++ defaultIxFiles) + indexFn = doIndex' filePathSendFile mimeFn indexFiles + +-- | Serve files from a directory and its subdirectories (strict ByteString version). +-- +-- WARNING: the entire file will be read into RAM before being served. You should probably use 'fileServe' instead. +fileServeStrict :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => + [FilePath] -- ^ index file names, in case the next argument is a directory + -> FilePath -- ^ file/directory to serve + -> m Response +fileServeStrict ixFiles localPath = + fileServe' serveFn mimeFn indexFn localPath + where + serveFn = filePathStrict + mimeFn = guessContentTypeM mimeTypes + indexFiles = (ixFiles ++ defaultIxFiles) + indexFn = doIndex' filePathSendFile mimeFn indexFiles + +-- * Index + +-- | attempt to serve index files +doIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) + => [FilePath] -- ^ list of possible index files (e.g., @index.html@) + -> MimeMap -- ^ see also 'mimeTypes' + -> FilePath -- ^ directory on disk to search for index files + -> m Response +doIndex ixFiles mimeMap localPath = doIndex' filePathSendFile (guessContentTypeM mimeMap) ixFiles localPath + +doIndexLazy :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) + => [String] + -> MimeMap + -> FilePath + -> m Response +doIndexLazy ixFiles mimeMap localPath = doIndex' filePathLazy (guessContentTypeM mimeMap) ixFiles localPath + +doIndexStrict :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) + => [String] + -> MimeMap + -> FilePath + -> m Response +doIndexStrict ixFiles mimeMap localPath = doIndex' filePathStrict (guessContentTypeM mimeMap) ixFiles localPath + +doIndex' :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) + => (String -> FilePath -> m Response) + -> (FilePath -> m String) + -> [String] + -> FilePath + -> m Response +doIndex' serveFn mimeFn ixFiles fp = + msum [ tryIndex serveFn mimeFn ixFiles fp + , forbidden $ toResponse "Directory index forbidden" + ] + +-- | try to find an index file, calls mzero on failure +tryIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) + => (String -> FilePath -> m Response) -- ^ usually 'filePathSendFile' + -> (FilePath -> m String) -- ^ function to calculate mime type, usually 'guessContentTypeM' + -> [String] -- ^ list of index files. See also 'defaultIxFiles' + -> FilePath -- ^ directory to search in + -> m Response +tryIndex _serveFn _mime [] _fp = mzero +tryIndex serveFn mimeFn (index:rest) fp = + do let path = fp index + fe <- liftIO $ doesFileExist path + if fe + then serveFileUsing serveFn mimeFn path + else tryIndex serveFn mimeFn rest fp + +-- * Directory Browsing + +browseIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m, ToMessage b) => + (FilePath -> [FilePath] -> m b) + -> (String -> FilePath -> m Response) + -> (FilePath -> m String) + -> [String] + -> FilePath + -> m Response +browseIndex renderFn _serveFn _mimeFn _ixFiles localPath = + do c <- liftIO $ getDirectoryContents localPath + listing <- renderFn localPath $ filter (/= ".") (sort c) + ok $ toResponse $ listing + +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 +-- +-- see also: 'browseIndex', 'renderDirectoryContentsTable' +renderDirectoryContents :: (MonadIO m) => + FilePath -- ^ path to directory on disk + -> [FilePath] -- ^ list of entries in that path + -> m H.Html +renderDirectoryContents localPath fps = + do fps' <- liftIO $ mapM (getMetaData localPath) fps + return $ H.html $ do + H.head $ do + H.title $ H.toHtml "Directory Listing" + H.meta ! A.httpEquiv (H.toValue "Content-Type") ! A.content (H.toValue "text/html;charset=utf-8") + H.style $ H.toHtml $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }" + , "table, th, td { border: 1px solid #353948; }" + , "td.size { text-align: right; font-size: 0.7em; width: 50px }" + , "td.date { text-align: right; font-size: 0.7em; width: 130px }" + , "td { padding-right: 1em; padding-left: 1em; }" + , "th.first { background-color: white; width: 24px }" + , "td.first { padding-right: 0; padding-left: 0; text-align: center }" + , "tr { background-color: white; }" + , "tr.alt { background-color: #A3B5BA}" + , "th { background-color: #3C4569; color: white; font-size: 1em; }" + , "h1 { width: 760px; margin: 1em auto; font-size: 1em }" + , "img { width: 20px }" + , "a { text-decoration: none }" + ] + H.body $ do + H.h1 $ H.toHtml "Directory Listing" + renderDirectoryContentsTable fps' + +-- | a function to generate an HTML table showing the contents of a directory on the disk +-- +-- This function generates most of the content of the +-- 'renderDirectoryContents' page. If you want to style the page +-- differently, or add google analytics code, etc, you can just create +-- a new page template to wrap around this HTML. +-- +-- see also: 'getMetaData', 'renderDirectoryContents' +renderDirectoryContentsTable :: [(FilePath, Maybe UTCTime, Maybe Integer, EntryKind)] -- ^ list of files+meta data, see 'getMetaData' + -> H.Html +renderDirectoryContentsTable fps = + H.table $ do H.thead $ do H.th $ H.toHtml "" + H.th $ H.toHtml "Name" + H.th $ H.toHtml "Last modified" + H.th $ H.toHtml "Size" + H.tbody $ mapM_ mkRow (zip fps $ cycle [False, True]) + where + mkRow :: ((FilePath, Maybe UTCTime, Maybe Integer, EntryKind), Bool) -> H.Html + mkRow ((fp, modTime, count, kind), alt) = + (if alt then (! A.class_ (H.toValue "alt")) else id) $ + H.tr $ do + H.td (mkKind kind) + H.td (H.a ! A.href (H.toValue fp) $ H.toHtml fp) + H.td ! A.class_ (H.toValue "date") $ (H.toHtml $ maybe "-" (formatTime defaultTimeLocale "%d-%b-%Y %X %Z") modTime) + (maybe id (\c -> (! A.title (H.toValue (show c)))) count) (H.td ! A.class_ (H.toValue "size") $ (H.toHtml $ maybe "-" prettyShow count)) + mkKind :: EntryKind -> H.Html + mkKind File = return () + mkKind Directory = H.toHtml "➦" + mkKind UnknownKind = return () + prettyShow x + | x > 1024 = prettyShowK $ x `div` 1024 + | otherwise = addCommas "B" x + prettyShowK x + | x > 1024 = prettyShowM $ x `div` 1024 + | otherwise = addCommas "KB" x + prettyShowM x + | x > 1024 = prettyShowG $ x `div` 1024 + | otherwise = addCommas "MB" x + prettyShowG x = addCommas "GB" x + addCommas s = (++ (' ' : s)) . reverse . addCommas' . reverse . show + addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e) + addCommas' x = x + + +-- | look up the meta data associated with a file +getMetaData :: FilePath -- ^ path to directory on disk containing the entry + -> FilePath -- ^ entry in that directory + -> IO (FilePath, Maybe UTCTime, Maybe Integer, EntryKind) +getMetaData localPath fp = + do let localFp = localPath fp + modTime <- (Just <$> getModificationTime localFp) `E.catch` + (\(_ :: IOException) -> return Nothing) + count <- do de <- doesDirectoryExist localFp + if de + then do return Nothing + else do bracket (openBinaryFile localFp ReadMode) hClose (fmap Just . hFileSize) + `E.catch` (\(_e :: IOException) -> return Nothing) + kind <- do fe <- doesFileExist localFp + if fe + then return File + else do de <- doesDirectoryExist localFp + if de + then return Directory + else return UnknownKind + return (if kind == Directory then (fp ++ "/") else fp, modTime, count, kind) + +-- | see 'serveDirectory' +data Browsing + = EnableBrowsing | DisableBrowsing + deriving (Eq, Enum, Ord, Read, Show, Data) + +-- | Serve files and directories from a directory and its subdirectories using 'sendFile'. +-- +-- Usage: +-- +-- > serveDirectory EnableBrowsing ["index.html"] "path/to/files/on/disk" +-- +-- If the requested path does not match a file or directory on the +-- disk, then 'serveDirectory' calls 'mzero'. +-- +-- If the requested path is a file then the file is served normally. +-- +-- If the requested path is a directory, then the result depends on +-- what the first two arguments to the function are. +-- +-- The first argument controls whether directory browsing is +-- enabled. +-- +-- The second argument is a list of index files (such as +-- index.html). +-- +-- When a directory is requested, 'serveDirectory' will first try to +-- find one of the index files (in the order they are listed). If that +-- fails, it will show a directory listing if 'EnableBrowsing' is set, +-- otherwise it will return @forbidden \"Directory index forbidden\"@. +-- +-- Here is an explicit list of all the possible outcomes when the +-- argument is a (valid) directory: +-- +-- [@'DisableBrowsing', empty index file list@] +-- +-- This will always return, forbidden \"Directory index forbidden\" +-- +-- [@'DisableBrowsing', non-empty index file list@] +-- +-- 1. If an index file is found it will be shown. +-- +-- 2. Otherwise returns, forbidden \"Directory index forbidden\" +-- +-- [@'EnableBrowsing', empty index file list@] +-- +-- Always shows a directory index. +-- +-- [@'EnableBrowsing', non-empty index file list@] +-- +-- 1. If an index file is found it will be shown +-- +-- 2. Otherwise shows a directory index +-- +-- see also: 'defaultIxFiles', 'serveFile' +serveDirectory :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => + Browsing -- ^ allow directory browsing + -> [FilePath] -- ^ index file names, in case the requested path is a directory + -> FilePath -- ^ file/directory to serve + -> m Response +serveDirectory browsing ixFiles localPath = + serveDirectory' browsing ixFiles mimeFn localPath + where + mimeFn = guessContentTypeM mimeTypes + + +-- | like 'serveDirectory' but with custom mimeTypes +serveDirectory' :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) + => Browsing -- ^ allow directory browsing + -> [FilePath] -- ^ index file names, in case the requested path is a directory + -> (FilePath -> m String) -- ^ function which returns the mime-type for FilePath + -> FilePath -- ^ file/directory to serve + -> m Response +serveDirectory' browsing ixFiles mimeFn localPath = + fileServe' serveFn mimeFn indexFn localPath + where + serveFn = filePathSendFile + indexFn fp = + msum [ tryIndex filePathSendFile mimeFn ixFiles fp + , if browsing == EnableBrowsing + then browseIndex renderDirectoryContents filePathSendFile mimeFn ixFiles fp + else forbidden $ toResponse "Directory index forbidden" + ] + + + +-- | Ready collection of common mime types. +-- 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","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/HTTP/Client.hs b/src/Happstack/Server/HTTP/Client.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTP/Client.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Happstack.Server.HTTP.Client where - - -import Happstack.Server.HTTP.Handler -import Happstack.Server.HTTP.Types -import Data.Maybe -import qualified Data.ByteString.Lazy.Char8 as L - -import System.IO -import qualified Data.ByteString.Char8 as B -import Network - -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 read $ 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 - -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 = unproxify rq {rqPaths = host: rqPaths rq} - where - host::String - host = maybe defaultHost (f .B.unpack) $ - getHeader "host" rq - f = maybe defaultHost id . flip lookup list - diff --git a/src/Happstack/Server/HTTP/Clock.hs b/src/Happstack/Server/HTTP/Clock.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTP/Clock.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# OPTIONS -fno-cse #-} -module Happstack.Server.HTTP.Clock(getApproximateTime) where - -import Control.Concurrent -import Data.IORef -import System.IO.Unsafe -import System.Time -import System.Locale - -import qualified Data.ByteString.Char8 as B - -mkTime :: IO B.ByteString -mkTime = do now <- getClockTime - return $ B.pack (formatCalendarTime defaultTimeLocale "%a, %d %b %Y %X GMT" (toUTCTime now)) - - -{-# NOINLINE clock #-} -clock :: IORef B.ByteString -clock = unsafePerformIO $ do - ref <- newIORef =<< mkTime - forkIO $ updater ref - return ref - -updater :: IORef B.ByteString -> IO () -updater ref = do threadDelay (10^(6 :: Int) * 1) -- Every second - writeIORef ref =<< mkTime - updater ref - -getApproximateTime :: IO B.ByteString -getApproximateTime = readIORef clock diff --git a/src/Happstack/Server/HTTP/FileServe.hs b/src/Happstack/Server/HTTP/FileServe.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTP/FileServe.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Happstack.Server.HTTP.FileServe - ( - MimeMap,fileServe, mimeTypes,isDot, blockDotFiles,doIndex,errorwrapper - ) where - -import Control.Exception.Extensible - -import Control.Monad.Reader -import Control.Monad.Trans -import Data.List -import Data.Maybe -import Data.Int -import Happstack.Server.SimpleHTTP hiding (path) -import System.Directory -import System.IO -import System.Locale(defaultTimeLocale) -import System.Log.Logger -import System.Time -- (formatCalendarTime, toUTCTime,TOD(..)) -import qualified Data.ByteString.Char8 as P -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.Map as Map -import qualified Happstack.Server.SimpleHTTP as SH - -ioErrors :: SomeException -> Maybe IOException -ioErrors = fromException - -errorwrapper :: (MonadIO m, MonadPlus m, FilterMonad Response m) => String -> String -> m Response -errorwrapper binarylocation loglocation - = require getErrorLog $ \errorLog -> - return $ toResponse errorLog - where getErrorLog - = handleJust ioErrors (const (return Nothing)) $ - do bintime <- getModificationTime binarylocation - logtime <- getModificationTime loglocation - if (logtime > bintime) - then fmap Just $ readFile loglocation -- fileServe [loglocation] [] "./" - else return Nothing - -type MimeMap = Map.Map String String - -doIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m) => - [String] -> MimeMap -> String -> m Response -doIndex [] _mime _fp = do forbidden $ toResponse "Directory index forbidden" -doIndex (index:rest) mime fp = - do - let path = fp++'/':index - --print path - fe <- liftIO $ doesFileExist path - if fe then retFile path else doIndex rest mime fp - where retFile = returnFile mime -defaultIxFiles :: [String] -defaultIxFiles= ["index.html","index.xml","index.gif"] - - -fileServe :: (ServerMonad m, FilterMonad Response m, MonadIO m) => [FilePath] -> FilePath -> m Response -fileServe ixFiles localpath = - fileServe' localpath (doIndex (ixFiles++defaultIxFiles)) mimeTypes - --- | Serve files with a mime type map under a directory. --- Uses the function to transform URIs to FilePaths. -fileServe' :: (ServerMonad m, FilterMonad Response m, MonadIO m) => - String - -> (Map.Map String String -> String -> m Response) - -> Map.Map String String - -> m Response -fileServe' localpath fdir mime = do - rq <- askRq - let fp2 = takeWhile (/=',') fp - fp = filepath - safepath = filter (\x->not (null x) && head x /= '.') (rqPaths rq) - filepath = intercalate "/" (localpath:safepath) - fp' = if null safepath then "" else last safepath - if "TESTH" `isPrefixOf` fp' - then renderResponse mime $ fakeFile $ (read $ drop 5 $ fp' :: Integer) - else do - fe <- liftIO $ doesFileExist fp - fe2 <- liftIO $ doesFileExist fp2 - de <- liftIO $ doesDirectoryExist fp - -- error $ "show ilepath: " ++show (fp,de) - let status | de = "DIR" - | fe = "file" - | fe2 = "group" - | True = "NOT FOUND" - liftIO $ logM "Happstack.Server.HTTP.FileServe" DEBUG ("fileServe: "++show fp++" \t"++status) - if de then fdir mime fp else do - getFile mime fp >>= flip either (renderResponse mime) - (const $ returnGroup localpath mime safepath) - -returnFile :: (ServerMonad m, FilterMonad Response m, MonadIO m) => - Map.Map String String -> String -> m Response -returnFile mime fp = - getFile mime fp >>= either fileNotFound (renderResponse mime) - --- if fp has , separated then return concatenation with content-type of last --- and last modified of latest -tr :: (Eq a) => a -> a -> [a] -> [a] -tr a b = map (\x->if x==a then b else x) -ltrim :: String -> String -ltrim = dropWhile (flip elem " \t\r") - -returnGroup :: (ServerMonad m, FilterMonad Response m, MonadIO m) => - String -> Map.Map String String -> [String] -> m Response -returnGroup localPath mime fp = do - let fps0 = map ((:[]). ltrim) $ lines $ tr ',' '\n' $ last fp - fps = map (intercalate "/" . ((localPath:init fp) ++)) fps0 - - -- if (head $ head fps0)=="TEST" then renderResponse mime rq fakeFile else do - - mbFiles <- mapM (getFile mime) $ fps - let notFounds = [x | Left x <- mbFiles] - files = [x | Right x <- mbFiles] - if not $ null notFounds - then fileNotFound $ drop (length localPath) $ head notFounds else do - let totSize = sum $ map (snd . fst) files - maxTime = maximum $ map (fst . fst) files :: ClockTime - - renderResponse mime ((maxTime,totSize),(fst $ snd $ head files, - L.concat $ map (snd . snd) files)) - - - -fileNotFound :: (Monad m, FilterMonad Response m) => String -> m Response -fileNotFound fp = do setResponseCode 404 - return $ toResponse $ "File not found "++ fp ---fakeLen = 71* 1024 -fakeFile :: (Integral a) => - a -> ((ClockTime, Int64), (String, L.ByteString)) -fakeFile fakeLen = ((TOD 0 0,L.length body),("text/javascript",body)) - where - body = L.pack $ (("//"++(show len)++" ") ++ ) $ (replicate len '0') ++ "\n" - len = fromIntegral fakeLen - -getFile :: (MonadIO m) => - Map.Map String String - -> String - -> m (Either String ((ClockTime, Integer), (String, L.ByteString))) -getFile mime fp = do - let ct = Map.findWithDefault "text/plain" (getExt fp) mime - fe <- liftIO $ doesFileExist fp - if not fe then return $ Left fp else do - - time <- liftIO $ getModificationTime fp - h <- liftIO $ openBinaryFile fp ReadMode - size <- liftIO $ hFileSize h - lbs <- liftIO $ L.hGetContents h - return $ Right ((time,size),(ct,lbs)) - -renderResponse :: (Monad m, - ServerMonad m, - FilterMonad Response m, - Show t1) => - t - -> ((ClockTime, t1), (String, L.ByteString)) - -> m Response -renderResponse _ ((modtime,size),(ct,body)) = do - rq <- askRq - let notmodified = getHeader "if-modified-since" rq == Just (P.pack $ repr) - repr = formatCalendarTime defaultTimeLocale - "%a, %d %b %Y %X GMT" (toUTCTime modtime) - -- "Mon, 07 Jan 2008 19:51:02 GMT" - -- when (isJust $ getHeader "if-modified-since" rq) $ error $ show $ getHeader "if-modified-since" rq - if notmodified then do setResponseCode 304 ; return $ toResponse "" else do - -- modifyResponse (setHeader "HUH" $ show $ (fmap P.unpack mod == Just repr,mod,Just repr)) - setHeaderM "Last-modified" repr - -- if %Z or UTC are in place of GMT below, wget complains that the last-modified header is invalid - setHeaderM "Content-Length" (show size) - setHeaderM "Content-Type" ct - return $ resultBS 200 body - - - - -getExt :: String -> String -getExt = reverse . takeWhile (/='.') . reverse - --- | Ready collection of common mime types. -mimeTypes :: MimeMap -mimeTypes = Map.fromList - [("xml","application/xml") - ,("xsl","application/xml") - ,("js","text/javascript") - ,("html","text/html") - ,("css","text/css") - ,("gif","image/gif") - ,("jpg","image/jpeg") - ,("png","image/png") - ,("txt","text/plain") - ,("doc","application/msword") - ,("exe","application/octet-stream") - ,("pdf","application/pdf") - ,("zip","application/zip") - ,("gz","application/x-gzip") - ,("ps","application/postscript") - ,("rtf","application/rtf") - ,("wav","application/x-wav") - ,("hs","text/plain")] - - --- | Prevents files of the form '.foo' or 'bar/.foo' from being served -blockDotFiles :: (Request -> IO Response) -> Request -> IO Response -blockDotFiles fn rq - | isDot (intercalate "/" (rqPaths rq)) = return $ result 403 "Dot files not allowed." - | otherwise = fn rq - --- | Returns True if the given String either starts with a . or is of the form --- "foo/.bar", e.g. the typical *nix convention for hidden files. -isDot :: String -> Bool -isDot = isD . reverse - where - isD ('.':'/':_) = True - isD ['.'] = True - --isD ('/':_) = False - isD (_:cs) = isD cs - isD [] = False diff --git a/src/Happstack/Server/HTTP/Handler.hs b/src/Happstack/Server/HTTP/Handler.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTP/Handler.hs +++ /dev/null @@ -1,322 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-} - -module Happstack.Server.HTTP.Handler(request-- version,required - ,parseResponse,putRequest --- ,unchunkBody,val,testChunk,pack -) where --- ,fsepC,crlfC,pversion -import qualified Paths_happstack_server as Paths -import qualified Data.Version as DV -import Control.Exception.Extensible as E -import Control.Monad -import Data.List(elemIndex) -import Data.Char(toLower) -import Data.Maybe ( fromMaybe, fromJust, isJust, isNothing ) -import Prelude hiding (last) -import qualified Data.List as List -import qualified Data.ByteString.Char8 as P -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.Map as M -import System.IO -import Numeric -import Data.Int (Int64) -import Happstack.Server.Cookie -import Happstack.Server.HTTP.Clock -import Happstack.Server.HTTP.LazyLiner -import Happstack.Server.HTTP.Types -import Happstack.Server.HTTP.Multipart -import Happstack.Server.HTTP.RFC822Headers -import Happstack.Server.MessageWrap -import Happstack.Server.SURI(SURI(..),path,query) -import Happstack.Server.SURI.ParseURI -import Happstack.Util.TimeOut -import Happstack.Util.LogFormat (formatRequestCombined) -import Data.Time.Clock (getCurrentTime) -import System.Log.Logger (Priority(..), logM) - -log' = logM "Happstack.Server" - -request :: Conf -> Handle -> Host -> (Request -> IO Response) -> IO () -request conf h host handler = rloop conf h host handler =<< L.hGetContents h - -required :: String -> Maybe a -> Either String a -required err Nothing = Left err -required _ (Just a) = Right a - -transferEncodingC :: [Char] -transferEncodingC = "transfer-encoding" -rloop :: t - -> Handle - -> Host - -> (Request -> IO Response) - -> L.ByteString - -> IO () -rloop conf h host handler inputStr - | L.null inputStr = return () - | otherwise - = join $ withTimeOut (30 * second) $ - 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) - let headers = mkHeaders headers' - let contentLength = fromMaybe 0 $ fmap fst (P.readInt =<< getHeaderUnsafe contentlengthC headers) - (body, nextRequest) <- case () of - () | contentLength < 0 -> fail "negative content-length" - | isJust $ getHeader transferEncodingC headers -> - return $ consumeChunks restStr - | otherwise -> return (L.splitAt (fromIntegral contentLength) restStr) - let cookies = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" headers)), c <- cl ] -- Ugle - rqTmp = Request m (pathEls (path u)) (path u) (query u) - [] cookies v headers (Body body) host - rq = rqTmp{rqInputs = queryInput u ++ bodyInput rqTmp} - return (rq, nextRequest) - case parseRequest of - Left err -> error $ "failed to parse HTTP request: " ++ err - Right (req, rest) - -> return $ - do let ioseq act = act >>= \x -> x `seq` return x - res <- ioseq (handler req) `E.catch` \(e::E.SomeException) -> return $ result 500 $ "Server error: " ++ show e - - -- combined log format - time <- getCurrentTime - let host' = fst host - user = "-" - requestLine = unwords [show $ rqMethod req, rqUri req, show $ rqVersion req] - responseCode = rsCode res - size = toInteger $ L.length $ rsBody res - referer = B.unpack $ fromMaybe (B.pack "") $ getHeader "Referer" req - userAgent = B.unpack $ fromMaybe (B.pack "") $ getHeader "User-Agent" req - log' NOTICE $ formatRequestCombined host' user time requestLine responseCode size referer userAgent - - putAugmentedResult h req res - when (continueHTTP req res) $ rloop conf h host handler rest - -parseResponse :: L.ByteString -> Either String Response -parseResponse inputStr = - do (topStr,restStr) <- required "failed to separate response" $ - splitAtEmptyLine inputStr - (rsl,headerStr) <- required "failed to separate headers/body" $ - splitAtCRLF topStr - let (_,code) = responseLine rsl - headers' <- parseHeaders "host" (L.unpack headerStr) - let headers = mkHeaders headers' - let mbCL = fmap fst (B.readInt =<< getHeader "content-length" headers) - (body,_) <- - maybe (if (isNothing $ getHeader "transfer-encoding" headers) - then return (restStr,L.pack "") - else return $ consumeChunks restStr) - (\cl->return (L.splitAt (fromIntegral cl) restStr)) - mbCL - return $ Response {rsCode=code,rsHeaders=headers,rsBody=body,rsFlags=RsFlags True,rsValidator=Nothing} - --- http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html --- note this does NOT handle extenions -consumeChunks::L.ByteString->(L.ByteString,L.ByteString) -consumeChunks str = let (parts,tr,rest) = consumeChunksImpl str in (L.concat . (++ [tr]) .map snd $ parts,rest) - -consumeChunksImpl :: L.ByteString -> ([(Int64, L.ByteString)], L.ByteString, L.ByteString) -consumeChunksImpl str - | L.null str = ([],L.empty,str) - | chunkLen == 0 = let (last,rest') = L.splitAt lenLine1 str - (tr',rest'') = getTrailer rest' - in ([(0,last)],tr',rest'') - | otherwise = ((chunkLen,part):crest,tr,rest2) - where - line1 = head $ lazylines str - lenLine1 = (L.length line1) + 1 -- endchar - chunkLen = (fst $ head $ readHex $ L.unpack line1) - len = chunkLen + lenLine1 + 2 - (part,rest) = L.splitAt len str - (crest,tr,rest2) = consumeChunksImpl rest - getTrailer s = L.splitAt index s - where index | crlfLC `L.isPrefixOf` s = 2 - | otherwise = let iscrlf = L.zipWith (\a b -> a == '\r' && b == '\n') s . L.tail $ s - Just i = elemIndex True $ zipWith (&&) iscrlf (tail (tail iscrlf)) - in fromIntegral $ i+4 - -crlfLC :: L.ByteString -crlfLC = L.pack "\r\n" - --- Properly lazy version of 'lines' for lazy bytestrings -lazylines :: L.ByteString -> [L.ByteString] -lazylines s - | L.null s = [] - | otherwise = - let (l,s') = L.break ((==) '\n') s - in l : if L.null s' then [] - else lazylines (L.tail s') - -requestLine :: L.ByteString -> (Method, SURI, Version) -requestLine l = case P.words ((P.concat . L.toChunks) l) of - [rq,uri,ver] -> (method rq, SURI $ parseURIRef uri, version ver) - [rq,uri] -> (method rq, SURI $ parseURIRef uri,Version 0 9) - x -> error $ "requestLine cannot handle input: " ++ (show x) - -responseLine :: L.ByteString -> (B.ByteString, Int) -responseLine l = case B.words ((B.concat . L.toChunks) l) of - (v:c:_) -> version v `seq` (v,fst (fromJust (B.readInt c))) - x -> error $ "responseLine cannot handle input: " ++ (show x) - - -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)] - --- Result side - -staticHeaders :: Headers -staticHeaders = - foldr (uncurry setHeaderBS) (mkHeaders []) - [ (serverC, happsC), (contentTypeC, textHtmlC) ] - -putAugmentedResult :: Handle -> Request -> Response -> IO () -putAugmentedResult h req res = do - let ph (HeaderPair k vs) = map (\v -> P.concat [k, fsepC, v, crlfC]) vs - raw <- getApproximateTime - let cl = L.length $ rsBody res - let put = P.hPut h - -- TODO: Hoist static headers to the toplevel. - let stdHeaders = staticHeaders `M.union` - M.fromList ( [ (dateCLower, HeaderPair dateC [raw]) - , (connectionCLower, HeaderPair connectionC [if continueHTTP req res then keepAliveC else closeC]) - ] ++ if rsfContentLength (rsFlags res) - then [(contentlengthC, HeaderPair contentLengthC [P.pack (show cl)])] - else [] ) - allHeaders = rsHeaders res `M.union` stdHeaders -- 'union' prefers 'headers res' when duplicate keys are encountered. - - mapM_ put $ concat - [ (pversion $ rqVersion req) -- Print HTTP version - , [responseMessage $ rsCode res] -- Print responseCode - , concatMap ph (M.elems allHeaders) -- Print all headers - , [crlfC] - ] - when (rqMethod req /= HEAD) $ L.hPut h $ rsBody res - hFlush h - - -putRequest :: Handle -> Request -> IO () -putRequest h rq = do - let put = B.hPut h - ph (HeaderPair k vs) = map (\v -> B.concat [k, fsepC, v, crlfC]) vs - sp = [B.pack " "] - mapM_ put $ concat - [[B.pack $ show $ rqMethod rq],sp - ,[B.pack $ rqURL rq],sp - ,(pversion $ rqVersion rq), [crlfC] - ,concatMap ph (M.elems $ rqHeaders rq) - ,[crlfC] - ] - let Body body = rqBody rq - L.hPut h body - hFlush h - - - --- Version - -pversion :: Version -> [B.ByteString] -pversion (Version 1 1) = [http11] -pversion (Version 1 0) = [http10] -pversion (Version x y) = [P.pack "HTTP/", P.pack (show x), P.pack ".", P.pack (show y)] - -version :: B.ByteString -> Version -version x | x == http09 = Version 0 9 - | x == http10 = Version 1 0 - | x == http11 = Version 1 1 - | otherwise = error "Invalid HTTP version" - -http09 :: B.ByteString -http09 = P.pack "HTTP/0.9" -http10 :: B.ByteString -http10 = P.pack "HTTP/1.0" -http11 :: B.ByteString -http11 = P.pack "HTTP/1.1" - --- Constants - -connectionC :: B.ByteString -connectionC = P.pack "Connection" -connectionCLower :: B.ByteString -connectionCLower = P.map toLower connectionC -closeC :: B.ByteString -closeC = P.pack "close" -keepAliveC :: B.ByteString -keepAliveC = P.pack "Keep-Alive" -crlfC :: B.ByteString -crlfC = P.pack "\r\n" -fsepC :: B.ByteString -fsepC = P.pack ": " -contentTypeC :: B.ByteString -contentTypeC = P.pack "Content-Type" -contentLengthC :: B.ByteString -contentLengthC = P.pack "Content-Length" -contentlengthC :: B.ByteString -contentlengthC = P.pack "content-length" -dateC :: B.ByteString -dateC = P.pack "Date" -dateCLower :: B.ByteString -dateCLower = P.map toLower dateC -serverC :: B.ByteString -serverC = P.pack "Server" -happsC :: B.ByteString -happsC = P.pack $ "Happstack/" ++ DV.showVersion Paths.version -textHtmlC :: B.ByteString -textHtmlC = P.pack "text/html; charset=utf-8" - --- Response code names - -responseMessage :: (Num t) => t -> B.ByteString -responseMessage 100 = P.pack " 100 Continue\r\n" -responseMessage 101 = P.pack " 101 Switching Protocols\r\n" -responseMessage 200 = P.pack " 200 OK\r\n" -responseMessage 201 = P.pack " 201 Created\r\n" -responseMessage 202 = P.pack " 202 Accepted\r\n" -responseMessage 203 = P.pack " 203 Non-Authoritative Information\r\n" -responseMessage 204 = P.pack " 204 No Content\r\n" -responseMessage 205 = P.pack " 205 Reset Content\r\n" -responseMessage 206 = P.pack " 206 Partial Content\r\n" -responseMessage 300 = P.pack " 300 Multiple Choices\r\n" -responseMessage 301 = P.pack " 301 Moved Permanently\r\n" -responseMessage 302 = P.pack " 302 Found\r\n" -responseMessage 303 = P.pack " 303 See Other\r\n" -responseMessage 304 = P.pack " 304 Not Modified\r\n" -responseMessage 305 = P.pack " 305 Use Proxy\r\n" -responseMessage 307 = P.pack " 307 Temporary Redirect\r\n" -responseMessage 400 = P.pack " 400 Bad Request\r\n" -responseMessage 401 = P.pack " 401 Unauthorized\r\n" -responseMessage 402 = P.pack " 402 Payment Required\r\n" -responseMessage 403 = P.pack " 403 Forbidden\r\n" -responseMessage 404 = P.pack " 404 Not Found\r\n" -responseMessage 405 = P.pack " 405 Method Not Allowed\r\n" -responseMessage 406 = P.pack " 406 Not Acceptable\r\n" -responseMessage 407 = P.pack " 407 Proxy Authentication Required\r\n" -responseMessage 408 = P.pack " 408 Request Time-out\r\n" -responseMessage 409 = P.pack " 409 Conflict\r\n" -responseMessage 410 = P.pack " 410 Gone\r\n" -responseMessage 411 = P.pack " 411 Length Required\r\n" -responseMessage 412 = P.pack " 412 Precondition Failed\r\n" -responseMessage 413 = P.pack " 413 Request Entity Too Large\r\n" -responseMessage 414 = P.pack " 414 Request-URI Too Large\r\n" -responseMessage 415 = P.pack " 415 Unsupported Media Type\r\n" -responseMessage 416 = P.pack " 416 Requested range not satisfiable\r\n" -responseMessage 417 = P.pack " 417 Expectation Failed\r\n" -responseMessage 500 = P.pack " 500 Internal Server Error\r\n" -responseMessage 501 = P.pack " 501 Not Implemented\r\n" -responseMessage 502 = P.pack " 502 Bad Gateway\r\n" -responseMessage 503 = P.pack " 503 Service Unavailable\r\n" -responseMessage 504 = P.pack " 504 Gateway Time-out\r\n" -responseMessage 505 = P.pack " 505 HTTP Version not supported\r\n" -responseMessage x = P.pack (show x ++ "\r\n") - diff --git a/src/Happstack/Server/HTTP/LazyLiner.hs b/src/Happstack/Server/HTTP/LazyLiner.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTP/LazyLiner.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module Happstack.Server.HTTP.LazyLiner - (Lazy, newLinerHandle, headerLines, getBytes, getBytesStrict, getRest, L.toChunks - ) where - -import Control.Concurrent.MVar -import System.IO -import qualified Data.ByteString.Char8 as P -import qualified Data.ByteString.Lazy.Char8 as L - -newtype Lazy = Lazy (MVar L.ByteString) - -newLinerHandle :: Handle -> IO Lazy -newLinerHandle h = fmap Lazy (newMVar =<< L.hGetContents h) - -headerLines :: Lazy -> IO [P.ByteString] -headerLines (Lazy mv) = modifyMVar mv $ \l -> do - let loop acc r0 = let (h,r) = L.break ((==) ch) r0 - ph = toStrict h - phl = P.length ph - ph2 = if phl == 0 || P.last ph /= '\x0D' then ph else P.init ph - ch = '\x0A' - r' = if L.null r then r else L.tail r - in if P.length ph2 == 0 then (r', reverse acc) else loop (ph2:acc) r' - return $ loop [] l - -getBytesStrict :: Lazy -> Int -> IO P.ByteString -getBytesStrict (Lazy mv) len = modifyMVar mv $ \l -> do - let (h,p) = L.splitAt (fromIntegral len) l - return (p, toStrict h) - -getBytes :: Lazy -> Int -> IO L.ByteString -getBytes (Lazy mv) len = modifyMVar mv $ \l -> do - let (h,p) = L.splitAt (fromIntegral len) l - return (p, h) - -getRest :: Lazy -> IO L.ByteString -getRest (Lazy mv) = modifyMVar mv $ \l -> return (L.empty, l) - -toStrict :: L.ByteString -> P.ByteString -toStrict = P.concat . L.toChunks diff --git a/src/Happstack/Server/HTTP/Listen.hs b/src/Happstack/Server/HTTP/Listen.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTP/Listen.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-} -module Happstack.Server.HTTP.Listen(listen) where - -import Happstack.Server.HTTP.Types -import Happstack.Server.HTTP.Handler -import Happstack.Server.HTTP.Socket (acceptLite) -import Control.Exception.Extensible as E -import Control.Concurrent -import Network(PortID(..), listenOn, sClose) -import System.IO -{- -#ifndef mingw32_HOST_OS --} -import System.Posix.Signals -{- -#endif --} -import System.Log.Logger (Priority(..), logM) -log':: Priority -> String -> IO () -log' = logM "Happstack.Server.HTTP.Listen" - -listen :: Conf -> (Request -> IO Response) -> IO () -listen conf hand = do -{- -#ifndef mingw32_HOST_OS --} - installHandler openEndedPipe Ignore Nothing -{- -#endif --} - let port' = port conf - log' NOTICE ("Listening on port " ++ show port') - s <- listenOn $ PortNumber $ toEnum port' - let work (h,hn,p) = do -- hSetBuffering h NoBuffering - let eh (x::SomeException) = log' ERROR ("HTTP request failed with: "++show x) - request conf h (hn,fromIntegral p) hand `E.catch` eh - hClose h - let loop = do acceptLite s >>= forkIO . work - loop - let pe e = log' ERROR ("ERROR in accept thread: "++ - show e) - let infi = loop `catchSome` pe >> infi -- loop `E.catch` pe >> infi - infi `finally` sClose s -{-- -#ifndef mingw32_HOST_OS --} - installHandler openEndedPipe Ignore Nothing - return () -{- -#endif --} - where -- why are these handlers needed? - - catchSome op h = op `E.catches` [ - Handler $ \(e :: ArithException) -> h (toException e), - Handler $ \(e :: ArrayException) -> h (toException e) - ] - diff --git a/src/Happstack/Server/HTTP/LowLevel.hs b/src/Happstack/Server/HTTP/LowLevel.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTP/LowLevel.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Happstack.Server.HTTP.LowLevel - (-- * HTTP Implementation - -- $impl - - -- * Problems - -- $problems - - -- * API - module Happstack.Server.HTTP.Handler, - module Happstack.Server.HTTP.Listen, - module Happstack.Server.HTTP.Types - ) where - -import Happstack.Server.HTTP.Handler -import Happstack.Server.HTTP.Listen -import Happstack.Server.HTTP.Types - --- $impl --- The Happstack HTTP implementation supports HTTP 1.0 and 1.1. --- Multiple request on a connection including pipelining is supported. - --- $problems --- Currently if a client sends an invalid HTTP request the whole --- connection is aborted and no further processing is done. --- --- When the connection times out Happstack closes it. In future it could --- send a 408 response but this may be problematic if the sending --- of a response caused the problem. diff --git a/src/Happstack/Server/HTTP/Multipart.hs b/src/Happstack/Server/HTTP/Multipart.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTP/Multipart.hs +++ /dev/null @@ -1,216 +0,0 @@ --- #hide - ------------------------------------------------------------------------------ --- | --- Module : Happstack.Server.HTTP.Multipart --- Copyright : (c) Peter Thiemann 2001,2002 --- (c) Bjorn Bringert 2005-2006 --- (c) Lemmih 2007 --- License : BSD-style --- --- Maintainer : lemmih@vo.com --- Stability : experimental --- Portability : xbnon-portable --- --- Parsing of the multipart format from RFC2046. --- Partly based on code from WASHMail. --- ------------------------------------------------------------------------------ -module Happstack.Server.HTTP.Multipart - ( - -- * Multi-part messages - MultiPart(..), BodyPart(..), Header - , parseMultipartBody, hGetMultipartBody - -- * Headers - , ContentType(..), ContentTransferEncoding(..) - , ContentDisposition(..) - , parseContentType - , parseContentTransferEncoding - , parseContentDisposition - , getContentType - , getContentTransferEncoding - , getContentDisposition - - , splitAtEmptyLine - , splitAtCRLF - ) where - -import Control.Monad -import Data.Int (Int64) -import Data.Maybe -import System.IO (Handle) - -import Happstack.Server.HTTP.RFC822Headers - -import qualified Data.ByteString.Lazy.Char8 as BS -import Data.ByteString.Lazy.Char8 (ByteString) - --- --- * Multi-part stuff. --- - -data MultiPart = MultiPart [BodyPart] - deriving (Show, Read, Eq, Ord) - -data BodyPart = BodyPart [Header] ByteString - deriving (Show, Read, Eq, Ord) - --- | Read a multi-part message from a 'ByteString'. -parseMultipartBody :: String -- ^ Boundary - -> ByteString -> Maybe MultiPart -parseMultipartBody b s = - do - ps <- splitParts (BS.pack b) s - liftM MultiPart $ mapM parseBodyPart ps - --- | Read a multi-part message from a 'Handle'. --- Fails on parse errors. -hGetMultipartBody :: String -- ^ Boundary - -> Handle - -> IO MultiPart -hGetMultipartBody b h = - do - s <- BS.hGetContents h - case parseMultipartBody b s of - Nothing -> fail "Error parsing multi-part message" - Just m -> return m - - - -parseBodyPart :: ByteString -> Maybe BodyPart -parseBodyPart s = - do - (hdr,bdy) <- splitAtEmptyLine s - hs <- parseM pHeaders "" (BS.unpack hdr) - return $ BodyPart hs bdy - --- --- * Splitting into multipart parts. --- - --- | Split a multipart message into the multipart parts. -splitParts :: ByteString -- ^ The boundary, without the initial dashes - -> ByteString - -> Maybe [ByteString] -splitParts b s = dropPreamble b s >>= spl - where - spl x = case splitAtBoundary b x of - Nothing -> Nothing - Just (s1,d,s2) | isClose b d -> Just [s1] - | otherwise -> spl s2 >>= Just . (s1:) - --- | Drop everything up to and including the first line starting --- with the boundary. Returns 'Nothing' if there is no --- line starting with a boundary. -dropPreamble :: ByteString -- ^ The boundary, without the initial dashes - -> ByteString - -> Maybe ByteString -dropPreamble b s | isBoundary b s = fmap snd (splitAtCRLF s) - | otherwise = dropLine s >>= dropPreamble b - --- | Split a string at the first boundary line. -splitAtBoundary :: ByteString -- ^ The boundary, without the initial dashes - -> ByteString -- ^ String to split. - -> Maybe (ByteString,ByteString,ByteString) - -- ^ The part before the boundary, the boundary line, - -- and the part after the boundary line. The CRLF - -- before and the CRLF (if any) after the boundary line - -- are not included in any of the strings returned. - -- Returns 'Nothing' if there is no boundary. -splitAtBoundary b s = spl 0 - where - spl i = case findCRLF (BS.drop i s) of - Nothing -> Nothing - Just (j,l) | isBoundary b s2 -> Just (s1,d,s3) - | otherwise -> spl (i+j+l) - where - s1 = BS.take (i+j) s - s2 = BS.drop (i+j+l) s - (d,s3) = splitAtCRLF_ s2 - --- | Check whether a string starts with two dashes followed by --- the given boundary string. -isBoundary :: ByteString -- ^ The boundary, without the initial dashes - -> ByteString - -> Bool -isBoundary b s = startsWithDashes s && b `BS.isPrefixOf` BS.drop 2 s - --- | Check whether a string for which 'isBoundary' returns true --- has two dashes after the boudary string. -isClose :: ByteString -- ^ The boundary, without the initial dashes - -> ByteString - -> Bool -isClose b = startsWithDashes . BS.drop (2+BS.length b) - --- | Checks whether a string starts with two dashes. -startsWithDashes :: ByteString -> Bool -startsWithDashes s = BS.pack "--" `BS.isPrefixOf` s - - --- --- * RFC 2046 CRLF --- - --- | Drop everything up to and including the first CRLF. -dropLine :: ByteString -> Maybe ByteString -dropLine = fmap snd . splitAtCRLF - --- | Split a string at the first empty line. The CRLF (if any) before the --- empty line is included in the first result. The CRLF after the --- empty line is not included in the result. --- 'Nothing' is returned if there is no empty line. -splitAtEmptyLine :: ByteString -> Maybe (ByteString, ByteString) -splitAtEmptyLine s | startsWithCRLF s = Just (BS.empty, dropCRLF s) - | otherwise = spl 0 - where - spl i = case findCRLF (BS.drop i s) of - Nothing -> Nothing - Just (j,l) | startsWithCRLF s2 -> Just (s1, dropCRLF s2) - | otherwise -> spl (i+j+l) - where (s1,s2) = BS.splitAt (i+j+l) s - --- | Split a string at the first CRLF. The CRLF is not included --- in any of the returned strings. -splitAtCRLF :: ByteString -- ^ String to split. - -> Maybe (ByteString,ByteString) - -- ^ Returns 'Nothing' if there is no CRLF. -splitAtCRLF s = case findCRLF s of - Nothing -> Nothing - Just (i,l) -> Just (s1, BS.drop l s2) - where (s1,s2) = BS.splitAt i s - --- | Like 'splitAtCRLF', but if no CRLF is found, the first --- result is the argument string, and the second result is empty. -splitAtCRLF_ :: ByteString -> (ByteString,ByteString) -splitAtCRLF_ s = fromMaybe (s,BS.empty) (splitAtCRLF s) - --- | Get the index and length of the first CRLF, if any. -findCRLF :: ByteString -- ^ String to split. - -> Maybe (Int64,Int64) -findCRLF s = - case findCRorLF s of - Nothing -> Nothing - Just j | BS.null (BS.drop (j+1) s) -> Just (j,1) - Just j -> case (BS.index s j, BS.index s (j+1)) of - ('\n','\r') -> Just (j,2) - ('\r','\n') -> Just (j,2) - _ -> Just (j,1) - -findCRorLF :: ByteString -> Maybe Int64 -findCRorLF = BS.findIndex (\c -> c == '\n' || c == '\r') - -startsWithCRLF :: ByteString -> Bool -startsWithCRLF s = not (BS.null s) && (c == '\n' || c == '\r') - where c = BS.index s 0 - --- | Drop an initial CRLF, if any. If the string is empty, --- nothing is done. If the string does not start with CRLF, --- the first character is dropped. -dropCRLF :: ByteString -> ByteString -dropCRLF s | BS.null s = BS.empty - | BS.null (BS.drop 1 s) = BS.empty - | c0 == '\n' && c1 == '\r' = BS.drop 2 s - | c0 == '\r' && c1 == '\n' = BS.drop 2 s - | otherwise = BS.drop 1 s - where c0 = BS.index s 0 - c1 = BS.index s 1 diff --git a/src/Happstack/Server/HTTP/RFC822Headers.hs b/src/Happstack/Server/HTTP/RFC822Headers.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTP/RFC822Headers.hs +++ /dev/null @@ -1,266 +0,0 @@ --- #hide - ------------------------------------------------------------------------------ --- | --- Module : Network.CGI.RFC822Headers --- Copyright : (c) Peter Thiemann 2001,2002 --- (c) Bjorn Bringert 2005-2006 --- (c) Lemmih 2007 --- License : BSD-style --- --- Maintainer : lemmih@vo.com --- Stability : experimental --- Portability : portable --- --- Parsing of RFC822-style headers (name, value pairs) --- Partly based on code from WASHMail. --- ------------------------------------------------------------------------------ -module Happstack.Server.HTTP.RFC822Headers - ( -- * Headers - Header, - pHeader, - pHeaders, - parseHeaders, - - -- * Content-type - ContentType(..), - getContentType, - parseContentType, - showContentType, - - -- * Content-transfer-encoding - ContentTransferEncoding(..), - getContentTransferEncoding, - parseContentTransferEncoding, - - -- * Content-disposition - ContentDisposition(..), - getContentDisposition, - parseContentDisposition, - - -- * Utilities - parseM - ) where - -import Data.Char -import Data.List -import Text.ParserCombinators.Parsec - -type Header = (String, String) - -pHeaders :: Parser [Header] -pHeaders = many pHeader - -parseHeaders :: Monad m => SourceName -> String -> m [Header] -parseHeaders = parseM pHeaders - -pHeader :: Parser Header -pHeader = - do name <- many1 headerNameChar - char ':' - many ws1 - line <- lineString - crLf - extraLines <- many extraFieldLine - return (map toLower name, concat (line:extraLines)) - -extraFieldLine :: Parser String -extraFieldLine = - do sp <- ws1 - line <- lineString - crLf - return (sp:line) - --- --- * Parameters (for Content-type etc.) --- - -showParameters :: [(String,String)] -> String -showParameters = concatMap f - where f (n,v) = "; " ++ n ++ "=\"" ++ concatMap esc v ++ "\"" - esc '\\' = "\\\\" - esc '"' = "\\\"" - esc c | c `elem` ['\\','"'] = '\\':[c] - | otherwise = [c] - -p_parameter :: Parser (String,String) -p_parameter = - do lexeme $ char ';' - p_name <- lexeme $ p_token - lexeme $ char '=' - -- Workaround for seemingly standardized web browser bug - -- 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 - else literalString - p_value <- litStr <|> p_token - return (map toLower p_name, p_value) - - --- --- * Content type --- - --- | A MIME media type value. --- The 'Show' instance is derived automatically. --- Use 'showContentType' to obtain the standard --- string representation. --- See for more --- information about MIME media types. -data ContentType = - ContentType { - -- | The top-level media type, the general type - -- of the data. Common examples are - -- \"text\", \"image\", \"audio\", \"video\", - -- \"multipart\", and \"application\". - ctType :: String, - -- | The media subtype, the specific data format. - -- Examples include \"plain\", \"html\", - -- \"jpeg\", \"form-data\", etc. - ctSubtype :: String, - -- | Media type parameters. On common example is - -- the charset parameter for the \"text\" - -- top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@. - ctParameters :: [(String, String)] - } - deriving (Show, Read, Eq, Ord) - --- | Produce the standard string representation of a content-type, --- e.g. \"text\/html; charset=ISO-8859-1\". -showContentType :: ContentType -> String -showContentType (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps - -pContentType :: Parser ContentType -pContentType = - do many ws1 - c_type <- p_token - lexeme $ char '/' - c_subtype <- lexeme $ p_token - c_parameters <- many p_parameter - return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters - --- | 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 = parseM pContentType "Content-type" - -getContentType :: Monad m => [Header] -> m ContentType -getContentType hs = lookupM "content-type" hs >>= parseContentType - --- --- * Content transfer encoding --- - -data ContentTransferEncoding = - ContentTransferEncoding String - deriving (Show, Read, Eq, Ord) - -pContentTransferEncoding :: Parser ContentTransferEncoding -pContentTransferEncoding = - do many ws1 - c_cte <- p_token - return $ ContentTransferEncoding (map toLower c_cte) - -parseContentTransferEncoding :: Monad m => String -> m ContentTransferEncoding -parseContentTransferEncoding = - parseM pContentTransferEncoding "Content-transfer-encoding" - -getContentTransferEncoding :: Monad m => [Header] -> m ContentTransferEncoding -getContentTransferEncoding hs = - lookupM "content-transfer-encoding" hs >>= parseContentTransferEncoding - --- --- * Content disposition --- - -data ContentDisposition = - ContentDisposition String [(String, String)] - deriving (Show, Read, Eq, Ord) - -pContentDisposition :: Parser ContentDisposition -pContentDisposition = - do many ws1 - c_cd <- p_token - c_parameters <- many p_parameter - return $ ContentDisposition (map toLower c_cd) c_parameters - -parseContentDisposition :: Monad m => String -> m ContentDisposition -parseContentDisposition = parseM pContentDisposition "Content-disposition" - -getContentDisposition :: Monad m => [Header] -> m ContentDisposition -getContentDisposition hs = - lookupM "content-disposition" hs >>= parseContentDisposition - --- --- * Utilities --- - -parseM :: Monad 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 n = maybe (fail ("No such field: " ++ show n)) return . lookup n - --- --- * Parsing utilities --- - --- | RFC 822 LWSP-char -ws1 :: Parser Char -ws1 = oneOf " \t" - -lexeme :: Parser a -> Parser a -lexeme p = do x <- p; many ws1; return x - --- | RFC 822 CRLF (but more permissive) -crLf :: Parser String -crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r" - --- | One line -lineString :: Parser String -lineString = many (noneOf "\n\r") - -literalString :: Parser String -literalString = do char '\"' - str <- many (noneOf "\"\\" <|> quoted_pair) - char '\"' - return str - --- No web browsers seem to implement RFC 2046 correctly, --- since they do not escape double quotes and backslashes --- in the filename parameter in multipart/form-data. --- --- Note that this eats everything until the last double quote on the line. -buggyLiteralString :: Parser String -buggyLiteralString = - do char '\"' - str <- manyTill anyChar (try lastQuote) - return str - where lastQuote = do char '\"' - notFollowedBy (try (many (noneOf "\"") >> char '\"')) - -headerNameChar :: Parser Char -headerNameChar = noneOf "\n\r:" - -especials, tokenchar :: [Char] -especials = "()<>@,;:\\\"/[]?.=" -tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials - -p_token :: Parser String -p_token = many1 (oneOf tokenchar) - -text_chars :: [Char] -text_chars = map chr ([1..9] ++ [11,12] ++ [14..127]) - -p_text :: Parser Char -p_text = oneOf text_chars - -quoted_pair :: Parser Char -quoted_pair = do char '\\' - p_text diff --git a/src/Happstack/Server/HTTP/Socket.hs b/src/Happstack/Server/HTTP/Socket.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTP/Socket.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Happstack.Server.HTTP.Socket(acceptLite) where - -import Happstack.Server.HTTP.SocketTH(supportsIPv6) -import Language.Haskell.TH.Syntax -import Happstack.Util.HostAddress -import qualified Network as N - ( PortID(PortNumber) - , socketPort - ) -import qualified Network.Socket as S - ( Socket(..) - , PortNumber() - , SockAddr(..) - , HostName - , accept - , socketToHandle - ) -import System.IO - --- alternative implementation of accept to work around EAI_AGAIN errors -acceptLite :: S.Socket -> IO (Handle, S.HostName, S.PortNumber) -acceptLite sock = do - (sock', addr) <- S.accept sock - h <- S.socketToHandle sock' ReadWriteMode - (N.PortNumber p) <- N.socketPort sock' - - let peer = $(if supportsIPv6 - then - return $ CaseE (VarE (mkName "addr")) - [Match - (ConP (mkName "S.SockAddrInet") - [WildP,VarP (mkName "ha")]) - (NormalB (AppE (VarE (mkName "showHostAddress")) - (VarE (mkName "ha")))) [] - ,Match (ConP (mkName "S.SockAddrInet6") [WildP,WildP,VarP (mkName "ha"),WildP]) - (NormalB (AppE (VarE (mkName "showHostAddress6")) (VarE (mkName "ha")))) [] - ,Match WildP (NormalB (AppE (VarE (mkName "error")) (LitE (StringL "Unsupported socket")))) []] - -- the above mess is the equivalent of this: - {-[| case addr of - (S.SockAddrInet _ ha) -> showHostAddress ha - (S.SockAddrInet6 _ _ ha _) -> showHostAddress6 ha - _ -> error "Unsupported socket" - |]-} - else - [| case addr of - (S.SockAddrInet _ ha) -> showHostAddress ha - _ -> error "Unsupported socket" - |]) - - return (h, peer, p) - diff --git a/src/Happstack/Server/HTTP/SocketTH.hs b/src/Happstack/Server/HTTP/SocketTH.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTP/SocketTH.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Happstack.Server.HTTP.SocketTH(supportsIPv6) where -import Language.Haskell.TH - -import Data.List -import Data.Maybe -import Network.Socket(SockAddr(..)) - --- find out at compile time if the SockAddr6 / HostAddress6 constructors are available -supportsIPv6 :: Bool -supportsIPv6 = $(let c = "Network.Socket.SockAddrInet6"; d = ''SockAddr in - do TyConI (DataD _ _ _ cs _) <- reify d - if isJust (find (\(NormalC n _) -> show n == c) cs) - then [| True |] - else [| False |] ) - diff --git a/src/Happstack/Server/HTTP/Types.hs b/src/Happstack/Server/HTTP/Types.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTP/Types.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-} - -module Happstack.Server.HTTP.Types - (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..), - rqURL, mkHeaders, - getHeader, getHeaderBS, getHeaderUnsafe, - hasHeader, hasHeaderBS, hasHeaderUnsafe, - setHeader, setHeaderBS, setHeaderUnsafe, - addHeader, addHeaderBS, addHeaderUnsafe, - setRsCode, -- setCookie, setCookies, - Conf(..), nullConf, result, resultBS, - redirect, -- redirect_, redirect', redirect'_, - RsFlags(..), nullRsFlags, noContentLength, - Version(..), Method(..), Headers, continueHTTP, - Host, ContentType(..) - ) where - - -import qualified Data.Map as M -import Data.Typeable(Typeable) -import Data.Maybe -import qualified Data.ByteString.Char8 as P -import Data.ByteString.Char8 (ByteString,pack) -import qualified Data.ByteString.Lazy.Char8 as L -import Happstack.Server.SURI -import Data.Char (toLower) - -import Happstack.Server.HTTP.Multipart ( ContentType(..) ) -import Happstack.Server.Cookie -import Data.List -import Text.Show.Functions () - --- | HTTP version -data Version = Version Int Int - deriving(Read,Eq) - -instance Show Version where - show (Version x y) = (show x) ++ "." ++ (show y) - -isHTTP1_1 :: Request -> Bool -isHTTP1_1 rq = case rqVersion rq of Version 1 1 -> True; _ -> False -isHTTP1_0 :: Request -> Bool -isHTTP1_0 rq = case rqVersion rq of Version 1 0 -> True; _ -> False - --- | Should the connection be used for further messages after this. --- | isHTTP1_0 && hasKeepAlive || isHTTP1_1 && hasNotConnectionClose -continueHTTP :: Request -> Response -> Bool ---continueHTTP rq res = isHTTP1_1 rq && getHeader' connectionC rq /= Just closeC && rsfContentLength (rsFlags res) -continueHTTP rq res = (isHTTP1_0 rq && checkHeaderBS connectionC keepaliveC rq) || - (isHTTP1_1 rq && not (checkHeaderBS connectionC closeC rq)) && rsfContentLength (rsFlags res) - --- | HTTP configuration -data Conf = Conf { port :: Int -- ^ Port for the server to listen on. - , validator :: Maybe (Response -> IO Response) - } - --- | Default configuration contains no validator and the port is set to 8000 -nullConf :: Conf -nullConf = Conf { port = 8000 - , validator = Nothing - } - --- | HTTP request method -data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT - deriving(Show,Read,Eq) - -data HeaderPair = HeaderPair { hName :: ByteString, hValue :: [ByteString] } deriving (Read,Show) --- | Combined headers. -type Headers = M.Map ByteString HeaderPair -- lowercased name -> (realname, value) - - - --- | Result flags -data RsFlags = RsFlags - { rsfContentLength :: Bool -- ^ whether a content-length header will be added to the result. - } deriving(Show,Read,Typeable) - --- | Default RsFlags that will include the content-length header -nullRsFlags :: RsFlags -nullRsFlags = RsFlags { rsfContentLength = True } --- | Don't display a Content-Lenght field for the 'Result'. -noContentLength :: Response -> Response -noContentLength res = res { rsFlags = upd } where upd = (rsFlags res) { rsfContentLength = False } - -data Input = Input - { inputValue :: L.ByteString - , inputFilename :: Maybe String - , inputContentType :: ContentType - } deriving (Show,Read,Typeable) - -type Host = (String,Int) - -data Response = Response { rsCode :: Int, - rsHeaders :: Headers, - rsFlags :: RsFlags, - rsBody :: L.ByteString, - rsValidator:: Maybe (Response -> IO Response) - } deriving (Show,Typeable) - -data Request = Request { rqMethod :: Method, - rqPaths :: [String], - rqUri :: String, - rqQuery :: String, - rqInputs :: [(String,Input)], - rqCookies :: [(String,Cookie)], - rqVersion :: Version, - rqHeaders :: Headers, - rqBody :: RqBody, - rqPeer :: Host - } deriving(Show,Read,Typeable) - - --- | Converts a Request into a String representing the corresponding URL -rqURL :: Request -> String -rqURL rq = '/':intercalate "/" (rqPaths rq) ++ (rqQuery rq) - -class HasHeaders a where - updateHeaders::(Headers->Headers)->a->a - headers::a->Headers - -instance HasHeaders Response where updateHeaders f rs = rs{rsHeaders=f $ rsHeaders rs} - headers = rsHeaders -instance HasHeaders Request where updateHeaders f rq = rq{rqHeaders = f $ rqHeaders rq} - headers = rqHeaders - -instance HasHeaders Headers where updateHeaders f = f - headers = id - -newtype RqBody = Body L.ByteString deriving (Read,Show,Typeable) - --- | Sets the Response status code to the provided Int and lifts the computation --- into a Monad. -setRsCode :: (Monad m) => Int -> Response -> m Response -setRsCode code rs = return rs {rsCode = code} - --- | Takes a list of (key,val) pairs and converts it into Headers. The --- keys will be converted to lowercase -mkHeaders :: [(String,String)] -> Headers -mkHeaders hdrs - = M.fromListWith join [ (P.pack (map toLower key), HeaderPair (P.pack key) [P.pack value]) | (key,value) <- hdrs ] - where join (HeaderPair key vs1) (HeaderPair _ vs2) = HeaderPair key (vs1++vs2) - --------------------------------------------------------------- --- Retrieving header information --------------------------------------------------------------- - --- | Lookup header value. Key is case-insensitive. -getHeader :: HasHeaders r => String -> r -> Maybe ByteString -getHeader = getHeaderBS . pack - --- | Lookup header value. Key is a case-insensitive bytestring. -getHeaderBS :: HasHeaders r => ByteString -> r -> Maybe ByteString -getHeaderBS = getHeaderUnsafe . P.map toLower - --- | Lookup header value with a case-sensitive key. The key must be lowercase. -getHeaderUnsafe :: HasHeaders r => ByteString -> r -> Maybe ByteString -getHeaderUnsafe key var = listToMaybe =<< fmap hValue (getHeaderUnsafe' key var) - --- | Lookup header with a case-sensitive key. The key must be lowercase. -getHeaderUnsafe' :: HasHeaders r => ByteString -> r -> Maybe HeaderPair -getHeaderUnsafe' key = M.lookup key . headers - --------------------------------------------------------------- --- Querying header status --------------------------------------------------------------- - --- | Returns True if the associated key is found in the Headers. The lookup --- is case insensitive. -hasHeader :: HasHeaders r => String -> r -> Bool -hasHeader key r = isJust (getHeader key r) - --- | Acts as 'hasHeader' with ByteStrings -hasHeaderBS :: HasHeaders r => ByteString -> r -> Bool -hasHeaderBS key r = isJust (getHeaderBS key r) - --- | Acts as 'hasHeaderBS' but the key is case sensitive. It should be --- in lowercase. -hasHeaderUnsafe :: HasHeaders r => ByteString -> r -> Bool -hasHeaderUnsafe key r = isJust (getHeaderUnsafe' key r) - -checkHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> Bool -checkHeaderBS key val = checkHeaderUnsafe (P.map toLower key) (P.map toLower val) - -checkHeaderUnsafe :: HasHeaders r => ByteString -> ByteString -> r -> Bool -checkHeaderUnsafe key val r - = case getHeaderUnsafe key r of - Just val' | P.map toLower val' == val -> True - _ -> False - - --------------------------------------------------------------- --- Setting header status --------------------------------------------------------------- - --- | Associates the key/value pair in the headers. Forces the key to be --- lowercase. -setHeader :: HasHeaders r => String -> String -> r -> r -setHeader key val = setHeaderBS (pack key) (pack val) - --- | Acts as 'setHeader' but with ByteStrings. -setHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r -setHeaderBS key val = setHeaderUnsafe (P.map toLower key) (HeaderPair key [val]) - --- | Sets the key to the HeaderPair. This is the only way to associate a key --- with multiple values via the setHeader* functions. Does not force the key --- to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. -setHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r -setHeaderUnsafe key val = updateHeaders (M.insert key val) - --------------------------------------------------------------- --- Adding headers --------------------------------------------------------------- - --- | Add a key/value pair to the header. If the key already has a value --- associated with it, then the value will be appended. --- Forces the key to be lowercase. -addHeader :: HasHeaders r => String -> String -> r -> r -addHeader key val = addHeaderBS (pack key) (pack val) - --- | Acts as addHeader except for ByteStrings -addHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r -addHeaderBS key val = addHeaderUnsafe (P.map toLower key) (HeaderPair key [val]) - --- | Add a key/value pair to the header using the underlying HeaderPair data --- type. Does not force the key to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. -addHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r -addHeaderUnsafe key val = updateHeaders (M.insertWith join key val) - where join (HeaderPair k vs1) (HeaderPair _ vs2) = HeaderPair k (vs1++vs2) - --- | Creates a Response with the given Int as the status code and the provided --- String as the body of the Response -result :: Int -> String -> Response -result code = resultBS code . L.pack - --- | Acts as 'result' but works with ByteStrings directly. -resultBS :: Int -> L.ByteString -> Response -resultBS code s = Response code M.empty nullRsFlags s Nothing - --- | Sets the Response's status code to the given Int and redirects to the given URI -redirect :: (ToSURI s) => Int -> s -> Response -> Response -redirect c s resp = setHeaderBS locationC (pack (render (toSURI s))) resp{rsCode = c} - --- constants here -locationC :: ByteString -locationC = P.pack "Location" -closeC :: ByteString -closeC = P.pack "close" -connectionC :: ByteString -connectionC = P.pack "Connection" -keepaliveC :: ByteString -keepaliveC = P.pack "Keep-Alive" - diff --git a/src/Happstack/Server/HTTPClient/HTTP.hs b/src/Happstack/Server/HTTPClient/HTTP.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTPClient/HTTP.hs +++ /dev/null @@ -1,1019 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-} ------------------------------------------------------------------------------ --- | --- Module : Happstack.Server.HTTPClient.HTTP --- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005 --- License : BSD --- --- Maintainer : bjorn@bringert.net --- Stability : experimental --- Portability : non-portable (not tested) --- --- An easy HTTP interface enjoy. --- --- * Changes by Simon Foster: --- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules --- - Created functions receiveHTTP and responseHTTP to allow server side interactions --- (although 100-continue is unsupported and I haven't checked for standard compliancy). --- - Pulled the transfer functions from sendHTTP to global scope to allow access by --- above functions. --- --- * Changes by Graham Klyne: --- - export httpVersion --- - use new URI module (similar to old, but uses revised URI datatype) --- --- * Changes by Bjorn Bringert: --- --- - handle URIs with a port number --- - added debugging toggle --- - disabled 100-continue transfers to get HTTP\/1.0 compatibility --- - change 'ioError' to 'throw' --- - Added simpleHTTP_, which takes a stream argument. --- --- * Changes from 0.1 --- - change 'openHTTP' to 'openTCP', removed 'closeTCP' - use 'close' from 'Stream' class. --- - added use of inet_addr to openHTTP, allowing use of IP "dot" notation addresses. --- - reworking of the use of Stream, including alterations to make 'sendHTTP' generic --- and the addition of a debugging stream. --- - simplified error handling. --- --- * TODO --- - request pipelining --- - https upgrade (includes full TLS, i.e. SSL, implementation) --- - use of Stream classes will pay off --- - consider C implementation of encryption\/decryption --- - comm timeouts --- - MIME & entity stuff (happening in separate module) --- - support \"*\" uri-request-string for OPTIONS request method --- --- --- * Header notes: --- --- [@Host@] --- Required by HTTP\/1.1, if not supplied as part --- of a request a default Host value is extracted --- from the request-uri. --- --- [@Connection@] --- If this header is present in any request or --- response, and it's value is "close", then --- the current request\/response is the last --- to be allowed on that connection. --- --- [@Expect@] --- Should a request contain a body, an Expect --- header will be added to the request. The added --- header has the value \"100-continue\". After --- a 417 \"Expectation Failed\" response the request --- is attempted again without this added Expect --- header. --- --- [@TransferEncoding,ContentLength,...@] --- if request is inconsistent with any of these --- header values then you may not receive any response --- or will generate an error response (probably 4xx). --- --- --- * Response code notes --- Some response codes induce special behaviour: --- --- [@1xx@] \"100 Continue\" will cause any unsent request body to be sent. --- \"101 Upgrade\" will be returned. --- Other 1xx responses are ignored. --- --- [@417@] The reason for this code is \"Expectation failed\", indicating --- that the server did not like the Expect \"100-continue\" header --- added to a request. Receipt of 417 will induce another --- request attempt (without Expect header), unless no Expect header --- had been added (in which case 417 response is returned). --- ------------------------------------------------------------------------------ -module Happstack.Server.HTTPClient.HTTP ( - module Happstack.Server.HTTPClient.Stream, - module Happstack.Server.HTTPClient.TCP, - - -- ** Constants - httpVersion, - - -- ** HTTP - Request(..), - Response(..), - RequestMethod(..), - simpleHTTP, simpleHTTP_, - sendHTTP, - sendHTTPPipelined, - receiveHTTP, - respondHTTP, - - -- ** Header Functions - HasHeaders, - Header(..), - HeaderName(..), - insertHeader, - insertHeaderIfMissing, - insertHeaders, - retrieveHeaders, - replaceHeader, - findHeader, - - -- ** URL Encoding - urlEncode, - urlDecode, - urlEncodeVars, - -) where - - - ------------------------------------------------------------------ ------------------- Imports -------------------------------------- ------------------------------------------------------------------ - -import Control.Exception.Extensible as Exception - --- Networking -import Network.URI -import Happstack.Server.HTTPClient.Stream -import Happstack.Server.HTTPClient.TCP - - --- Util -import Data.Bits ((.&.)) -import Data.Char -import Data.List (partition,elemIndex,intersperse) -import Data.Maybe -import Control.Monad (when,forM) -import Numeric (readHex) -import Text.ParserCombinators.ReadP -import System.IO - - - --- Turn on to enable HTTP traffic logging -debug :: Bool -debug = True -- False - --- File that HTTP traffic logs go to -httpLogFile :: String -httpLogFile = "http-debug.log" - ------------------------------------------------------------------ ------------------- Misc ----------------------------------------- ------------------------------------------------------------------ - --- remove leading and trailing whitespace. -trim :: String -> String -trim = let dropspace = dropWhile isSpace in - reverse . dropspace . reverse . dropspace - - --- Split a list into two parts, the delimiter occurs --- at the head of the second list. Nothing is returned --- when no occurance of the delimiter is found. -split :: Eq a => a -> [a] -> Maybe ([a],[a]) -split delim list = case delim `elemIndex` list of - Nothing -> Nothing - Just x -> Just $ splitAt x list - - - -crlf :: String -crlf = "\r\n" -sp :: String -sp = " " - ------------------------------------------------------------------ ------------------- Header Data ---------------------------------- ------------------------------------------------------------------ - - --- | The Header data type pairs header names & values. -data Header = Header HeaderName String - - -instance Show Header where - show (Header key value) = show key ++ ": " ++ value ++ crlf - - --- | HTTP Header Name type: --- Why include this at all? I have some reasons --- 1) prevent spelling errors of header names, --- 2) remind everyone of what headers are available, --- 3) might speed up searches for specific headers. --- --- Arguments against: --- 1) makes customising header names laborious --- 2) increases code volume. --- -data HeaderName = - -- Generic Headers -- - HdrCacheControl - | HdrConnection - | HdrDate - | HdrPragma - | HdrTransferEncoding - | HdrUpgrade - | HdrVia - - -- Request Headers -- - | HdrAccept - | HdrAcceptCharset - | HdrAcceptEncoding - | HdrAcceptLanguage - | HdrAuthorization - | HdrCookie - | HdrExpect - | HdrFrom - | HdrHost - | HdrIfModifiedSince - | HdrIfMatch - | HdrIfNoneMatch - | HdrIfRange - | HdrIfUnmodifiedSince - | HdrMaxForwards - | HdrProxyAuthorization - | HdrRange - | HdrReferer - | HdrUserAgent - - -- Response Headers - | HdrAge - | HdrLocation - | HdrProxyAuthenticate - | HdrPublic - | HdrRetryAfter - | HdrServer - | HdrSetCookie - | HdrVary - | HdrWarning - | HdrWWWAuthenticate - - -- Entity Headers - | HdrAllow - | HdrContentBase - | HdrContentEncoding - | HdrContentLanguage - | HdrContentLength - | HdrContentLocation - | HdrContentMD5 - | HdrContentRange - | HdrContentType - | HdrETag - | HdrExpires - | HdrLastModified - - -- Mime entity headers (for sub-parts) - | HdrContentTransferEncoding - - -- | Allows for unrecognised or experimental headers. - | HdrCustom String -- not in header map below. - deriving(Eq) - - --- Translation between header names and values, --- good candidate for improvement. -headerMap :: [ (String,HeaderName) ] -headerMap - = [ ("Cache-Control" ,HdrCacheControl ) - , ("Connection" ,HdrConnection ) - , ("Date" ,HdrDate ) - , ("Pragma" ,HdrPragma ) - , ("Transfer-Encoding" ,HdrTransferEncoding ) - , ("Upgrade" ,HdrUpgrade ) - , ("Via" ,HdrVia ) - , ("Accept" ,HdrAccept ) - , ("Accept-Charset" ,HdrAcceptCharset ) - , ("Accept-Encoding" ,HdrAcceptEncoding ) - , ("Accept-Language" ,HdrAcceptLanguage ) - , ("Authorization" ,HdrAuthorization ) - , ("From" ,HdrFrom ) - , ("Host" ,HdrHost ) - , ("If-Modified-Since" ,HdrIfModifiedSince ) - , ("If-Match" ,HdrIfMatch ) - , ("If-None-Match" ,HdrIfNoneMatch ) - , ("If-Range" ,HdrIfRange ) - , ("If-Unmodified-Since" ,HdrIfUnmodifiedSince ) - , ("Max-Forwards" ,HdrMaxForwards ) - , ("Proxy-Authorization" ,HdrProxyAuthorization) - , ("Range" ,HdrRange ) - , ("Referer" ,HdrReferer ) - , ("User-Agent" ,HdrUserAgent ) - , ("Age" ,HdrAge ) - , ("Location" ,HdrLocation ) - , ("Proxy-Authenticate" ,HdrProxyAuthenticate ) - , ("Public" ,HdrPublic ) - , ("Retry-After" ,HdrRetryAfter ) - , ("Server" ,HdrServer ) - , ("Vary" ,HdrVary ) - , ("Warning" ,HdrWarning ) - , ("WWW-Authenticate" ,HdrWWWAuthenticate ) - , ("Allow" ,HdrAllow ) - , ("Content-Base" ,HdrContentBase ) - , ("Content-Encoding" ,HdrContentEncoding ) - , ("Content-Language" ,HdrContentLanguage ) - , ("Content-Length" ,HdrContentLength ) - , ("Content-Location" ,HdrContentLocation ) - , ("Content-MD5" ,HdrContentMD5 ) - , ("Content-Range" ,HdrContentRange ) - , ("Content-Type" ,HdrContentType ) - , ("ETag" ,HdrETag ) - , ("Expires" ,HdrExpires ) - , ("Last-Modified" ,HdrLastModified ) - , ("Set-Cookie" ,HdrSetCookie ) - , ("Cookie" ,HdrCookie ) - , ("Expect" ,HdrExpect ) ] - - -instance Show HeaderName where - show (HdrCustom s) = s - show x = case filter ((==x).snd) headerMap of - [] -> error "headerMap incomplete" - (h:_) -> fst h - - - - - --- | This class allows us to write generic header manipulation functions --- for both 'Request' and 'Response' data types. -class HasHeaders x where - getHeaders :: x -> [Header] - setHeaders :: x -> [Header] -> x - - - --- Header manipulation functions -insertHeader, replaceHeader, insertHeaderIfMissing - :: HasHeaders a => HeaderName -> String -> a -> a - - --- | Inserts a header with the given name and value. --- Allows duplicate header names. -insertHeader name value x = setHeaders x newHeaders - where - newHeaders = (Header name value) : getHeaders x - - --- | Adds the new header only if no previous header shares --- the same name. -insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x) - where - newHeaders list@(h@(Header n _): rest) - | n == name = list - | otherwise = h : newHeaders rest - newHeaders [] = [Header name value] - - - --- | Removes old headers with duplicate name. -replaceHeader name value x = setHeaders x newHeaders - where - newHeaders = Header name value : [ h | h@(Header n _) <- getHeaders x, name /= n ] - - --- | Inserts multiple headers. -insertHeaders :: HasHeaders a => [Header] -> a -> a -insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs) - - --- | Gets a list of headers with a particular 'HeaderName'. -retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header] -retrieveHeaders name x = filter matchname (getHeaders x) - where - matchname (Header n _) | n == name = True - matchname _ = False - - --- | Lookup presence of specific HeaderName in a list of Headers --- Returns the value from the first matching header. -findHeader :: HasHeaders a => HeaderName -> a -> Maybe String -findHeader n = lookupHeader n . getHeaders - --- An anomally really: -lookupHeader :: HeaderName -> [Header] -> Maybe String -lookupHeader v (Header n s:t) | v == n = Just s - | otherwise = lookupHeader v t -lookupHeader _ _ = Nothing - - - ------------------------------------------------------------------ ------------------- HTTP Messages -------------------------------- ------------------------------------------------------------------ - - --- Protocol version -httpVersion :: String -httpVersion = "HTTP/1.1" - - --- | The HTTP request method, to be used in the 'Request' object. --- We are missing a few of the stranger methods, but these are --- not really necessary until we add full TLS. -data RequestMethod = HEAD | PUT | GET | POST | OPTIONS | TRACE | DELETE - deriving(Show,Eq) - -rqMethodMap :: [(String, RequestMethod)] -rqMethodMap = [("HEAD", HEAD), - ("PUT", PUT), - ("GET", GET), - ("POST", POST), - ("OPTIONS", OPTIONS), - ("TRACE", TRACE), - ("DELETE", DELETE)] - --- | An HTTP Request. --- The 'Show' instance of this type is used for message serialisation, --- which means no body data is output. -data Request = - Request { rqURI :: URI -- ^ might need changing in future - -- 1) to support '*' uri in OPTIONS request - -- 2) transparent support for both relative - -- & absolute uris, although this should - -- already work (leave scheme & host parts empty). - , rqMethod :: RequestMethod - , rqHeaders :: [Header] - , rqBody :: String - } - - - - --- Notice that request body is not included, --- this show function is used to serialise --- a request for the transport link, we send --- the body separately where possible. -instance Show Request where - show (Request u m h _) = - show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf - ++ concatMap show h ++ crlf - where - alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' - then u { uriPath = '/' : uriPath u } - else u - - -instance HasHeaders Request where - getHeaders = rqHeaders - setHeaders rq hdrs = rq { rqHeaders=hdrs } - - - - - - -type ResponseCode = (Int,Int,Int) -type ResponseData = (ResponseCode,String,[Header]) -type RequestData = (RequestMethod,URI,[Header]) - --- | An HTTP Response. --- The 'Show' instance of this type is used for message serialisation, --- which means no body data is output, additionally the output will --- show an HTTP version of 1.1 instead of the actual version returned --- by a server. -data Response = - Response { rspCode :: ResponseCode - , rspReason :: String - , rspHeaders :: [Header] - , rspBody :: String - } - - - --- This is an invalid representation of a received response, --- since we have made the assumption that all responses are HTTP/1.1 -instance Show Response where - show (Response (a,b,c) reason headers _) = - httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf - ++ concatMap show headers ++ crlf - - - -instance HasHeaders Response where - getHeaders = rspHeaders - setHeaders rsp hdrs = rsp { rspHeaders=hdrs } - ------------------------------------------------------------------ ------------------- Parsing -------------------------------------- ------------------------------------------------------------------ - -parseHeader :: String -> Result Header -parseHeader str = - case split ':' str of - Nothing -> Left (ErrorParse $ "Unable to parse header: " ++ str) - Just (k,v) -> Right $ Header (fn k) (trim $ drop 1 v) - where - fn k = case map snd $ filter (match k . fst) headerMap of - [] -> (HdrCustom k) - (h:_) -> h - - match :: String -> String -> Bool - match s1 s2 = map toLower s1 == map toLower s2 - - -parseHeaders :: [String] -> Result [Header] -parseHeaders = catRslts [] . map (parseHeader . clean) . joinExtended "" - where - -- Joins consecutive lines where the second line - -- begins with ' ' or '\t'. - joinExtended old (h : t) - | not (null h) && (head h == ' ' || head h == '\t') - = joinExtended (old ++ ' ' : tail h) t - | otherwise = old : joinExtended h t - joinExtended old [] = [old] - - clean [] = [] - clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t - | otherwise = h : clean t - - -- tollerant of errors? should parse - -- errors here be reported or ignored? - -- currently ignored. - catRslts :: [a] -> [Result a] -> Result [a] - catRslts list (h:t) = - case h of - Left _ -> catRslts list t - Right v -> catRslts (v:list) t - catRslts list [] = Right $ reverse list - - --- Parsing a request -parseRequestHead :: [String] -> Result RequestData -parseRequestHead [] = Left ErrorClosed -parseRequestHead (com:hdrs) = - requestCommand com `bindE` \(_version,rqm,uri) -> - parseHeaders hdrs `bindE` \hdrs' -> - Right (rqm,uri,hdrs') - where - requestCommand line - = case words line of - _yes@(rqm:uri:version) -> case (parseURIReference uri, lookup rqm rqMethodMap) of - (Just u, Just r) -> Right (version,r,u) - _ -> Left (ErrorParse $ "Request command line parse failure: " ++ line) - _no -> if null line - then Left ErrorClosed - else Left (ErrorParse $ "Request command line parse failure: " ++ line) - --- Parsing a response -parseResponseHead :: [String] -> Result ResponseData -parseResponseHead [] = Left ErrorClosed -parseResponseHead (sts:hdrs) = - responseStatus sts `bindE` \(_version,code,reason) -> - parseHeaders hdrs `bindE` \hdrs' -> - Right (code,reason,hdrs') - where - - responseStatus line - = case words line of - _yes@(version:code:reason) -> Right (version,match code,concatMap (++" ") reason) - _no -> if null line - then Left ErrorClosed -- an assumption - else Left (ErrorParse $ "Response status line parse failure: " ++ line) - - - match [a,b,c] = (digitToInt a, - digitToInt b, - digitToInt c) - match _ = (-1,-1,-1) -- will create appropriate behaviour - - - - ------------------------------------------------------------------ ------------------- HTTP Send / Recv ---------------------------------- ------------------------------------------------------------------ - -data Behaviour = Continue - | Retry - | Done - | ExpectEntity - | DieHorribly String - - - - - -matchResponse :: RequestMethod -> ResponseCode -> Behaviour -matchResponse rqst rsp = - case rsp of - (1,0,0) -> Continue - (1,0,1) -> Done -- upgrade to TLS - (1,_,_) -> Continue -- default - (2,0,4) -> Done - (2,0,5) -> Done - (2,_,_) -> ans - (3,0,4) -> Done - (3,0,5) -> Done - (3,_,_) -> ans - (4,1,7) -> Retry -- Expectation failed - (4,_,_) -> ans - (5,_,_) -> ans - (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised") - where - ans | rqst == HEAD = Done - | otherwise = ExpectEntity - - --- | Simple way to get a resource across a non-persistant connection. --- Headers that may be altered: --- Host Altered only if no Host header is supplied, HTTP\/1.1 --- requires a Host header. --- Connection Where no allowance is made for persistant connections --- the Connection header will be set to "close" -simpleHTTP :: Request -> IO (Result Response) -simpleHTTP r = - do - auth <- getAuth r - c <- openTCPPort (uriRegName auth) (port auth) - simpleHTTP_ c r - where - port auth = if null (uriPort auth) - then 80 - else read $ uriPort auth - - --- | Like 'simpleHTTP', but acting on an already opened stream. -simpleHTTP_ :: Stream s => s -> Request -> IO (Result Response) -simpleHTTP_ s r = - do - auth <- getAuth r - let r' = fixReq auth r - rsp <- if debug then do - s' <- debugStream httpLogFile s - sendHTTP s' r' - else - sendHTTP s r' - -- already done by sendHTTP because of "Connection: close" header - --; close s - return rsp - where - {- RFC 2616, section 5.1.2: - "The most common form of Request-URI is that used to identify a - resource on an origin server or gateway. In this case the absolute - path of the URI MUST be transmitted (see section 3.2.1, abs_path) as - the Request-URI, and the network location of the URI (authority) MUST - be transmitted in a Host header field." -} - -- we assume that this is the case, so we take the host name from - -- the Host header if there is one, otherwise from the request-URI. - -- Then we make the request-URI an abs_path and make sure that there - -- is a Host header. - fixReq :: URIAuth -> Request -> Request - fixReq URIAuth{uriRegName=h} req = - insertHeaderIfMissing HdrConnection "close" $ - insertHeaderIfMissing HdrHost h $ - req { rqURI = (rqURI req){ uriScheme = "", - uriAuthority = Nothing } } - --- | this is not the most graceful of implementations. --- The problem is that Network.URI.authority is --- deprecated. And we want to use Network.URI.URIAuth. --- --- So this method use to parse a "host" field as a URI --- auth, which is not stictly correct. We still --- fake that behavior here. -getAuth :: Monad m => Request -> m URIAuth -getAuth r = case auth of - Just x -> return x - Nothing -> fail $ "Error parsing URI authority '" - ++ show (rqURI r) ++ "'" - where - auth = case findHeader HdrHost r of - Just h -> Just $ fakeAuth h - Nothing -> uriAuthority (rqURI r) - fakeAuth h = fst . head $ (flip readP_to_S) h $ do - host<-many1 $ satisfy (\c -> c /= ':') - port<-option "" $ char ':' >> many1 get - return URIAuth{uriRegName=host, uriPort=port, uriUserInfo=""} - - -sendHTTP :: Stream s => s -> Request -> IO (Result Response) -sendHTTP conn rq - = do rst <- sendHTTPPipelined conn [rq] - case rst of - ([response],_) -> return (Right response) - (_,Just err) -> return (Left err) - (_,_) -> error "Case not supported in sendHTTP" - -sendHTTPPipelined :: Stream s => s -> [Request] -> IO ([Response],Maybe ConnError) -sendHTTPPipelined conn rqs = - do { (ok,rsp) <- Exception.catch (main (map fixHostHeader rqs)) - (\(e::SomeException) -> do { close conn; throw e }) - ; let fn list = when (any findConnClose list) - (close conn) - ; fn (map rqHeaders rqs ++ map rspHeaders ok) - ; return (ok,rsp) - } - where --- From RFC 2616, section 8.2.3: --- 'Because of the presence of older implementations, the protocol allows --- ambiguous situations in which a client may send "Expect: 100- --- continue" without receiving either a 417 (Expectation Failed) status --- or a 100 (Continue) status. Therefore, when a client sends this --- header field to an origin server (possibly via a proxy) from which it --- has never seen a 100 (Continue) status, the client SHOULD NOT wait --- for an indefinite period before sending the request body.' --- --- Since we would wait forever, I have disabled use of 100-continue for now. - main :: [Request] -> IO ([Response], Maybe ConnError) - main rqsts = - do - --let str = if null (rqBody rqst) - -- then show rqst - -- else show (insertHeader HdrExpect "100-continue" rqst) - -- write body immediately, don't wait for 100 CONTINUE - writeBlock conn $ concat $ intersperse "\r\n" [ show rqst ++ rqBody rqst | rqst <- rqsts ] - rets <- forM rqsts $ \rqst -> - do rsp <- getResponseHead - switchResponse True True rsp rqst - return (sequenceResponses rets) - - sequenceResponses :: [Result Response] -> ([Response], Maybe ConnError) - sequenceResponses = worker [] - where worker acc [] = (reverse acc, Nothing) - worker acc (Right x:xs) = worker (x:acc) xs - worker acc (Left x:_) = (reverse acc,Just x) - - -- reads and parses headers - getResponseHead :: IO (Result ResponseData) - getResponseHead = - do { lor <- readTillEmpty1 conn - ; return $ lor `bindE` parseResponseHead - } - - -- Hmmm, this could go bad if we keep getting "100 Continue" - -- responses... Except this should never happen according - -- to the RFC. - switchResponse :: Bool {- allow retry? -} - -> Bool {- is body sent? -} - -> Result ResponseData - -> Request - -> IO (Result Response) - - switchResponse _ _ (Left e) _ = return (Left e) - -- retry on connreset? - -- if we attempt to use the same socket then there is an excellent - -- chance that the socket is not in a completely closed state. - - switchResponse allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = - case matchResponse (rqMethod rqst) cd of - Continue - | not bdy_sent -> {- Time to send the body -} - do { val <- writeBlock conn (rqBody rqst) - ; case val of - Left e -> return (Left e) - Right _ -> - do { rsp <- getResponseHead - ; switchResponse allow_retry True rsp rqst - } - } - | otherwise -> {- keep waiting -} - do { rsp <- getResponseHead - ; switchResponse allow_retry bdy_sent rsp rqst - } - - Retry -> {- Request with "Expect" header failed. - Trouble is the request contains Expects - other than "100-Continue" -} - do { writeBlock conn (show rqst ++ rqBody rqst) - ; rsp <- getResponseHead - ; switchResponse False bdy_sent rsp rqst - } - - Done -> - return (Right $ Response cd rn hdrs "") - - DieHorribly str -> - return $ Left $ ErrorParse ("Invalid response: " ++ str) - - ExpectEntity -> - let tc = lookupHeader HdrTransferEncoding hdrs - cl = lookupHeader HdrContentLength hdrs - in - do { rslt <- case tc of - Nothing -> - case cl of - Just x -> linearTransfer conn (read x :: Int) - Nothing -> hopefulTransfer conn "" - Just x -> - case map toLower (trim x) of - "chunked" -> chunkedTransfer conn - _ -> uglyDeathTransfer conn - ; return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy) - } - - - -- Adds a Host header if one is NOT ALREADY PRESENT - fixHostHeader :: Request -> Request - fixHostHeader rq = - let uri = rqURI rq - h = fmap uriRegName $ uriAuthority uri - in case h of - Just x -> insertHeaderIfMissing HdrHost x rq - _ -> rq - - -- Looks for a "Connection" header with the value "close". - -- Returns True when this is found. - findConnClose :: [Header] -> Bool - findConnClose hdrs = - case lookupHeader HdrConnection hdrs of - Nothing -> False - Just x -> map toLower (trim x) == "close" - --- | Receive and parse a HTTP request from the given Stream. Should be used --- for server side interactions. -receiveHTTP :: Stream s => s -> IO (Result Request) -receiveHTTP conn = do rq <- getRequestHead - processRequest rq - where - -- reads and parses headers - getRequestHead :: IO (Result RequestData) - getRequestHead = - do { lor <- readTillEmpty1 conn - ; return $ lor `bindE` parseRequestHead - } - - processRequest (Left e) = return $ Left e - processRequest (Right (rm,uri,hdrs)) = - do -- FIXME : Also handle 100-continue. - let tc = lookupHeader HdrTransferEncoding hdrs - cl = lookupHeader HdrContentLength hdrs - rslt <- case tc of - Nothing -> - case cl of - Just x -> linearTransfer conn (read x :: Int) - Nothing -> return (Right ([], "")) -- hopefulTransfer "" - Just x -> - case map toLower (trim x) of - "chunked" -> chunkedTransfer conn - _ -> uglyDeathTransfer conn - - return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy) - - --- | Very simple function, send a HTTP response over the given stream. This --- could be improved on to use different transfer types. -respondHTTP :: Stream s => s -> Response -> IO () -respondHTTP conn rsp = do writeBlock conn (show rsp) - -- write body immediately, don't wait for 100 CONTINUE - writeBlock conn (rspBody rsp) - return () - --- The following functions were in the where clause of sendHTTP, they have --- been moved to global scope so other functions can access them. - --- | Used when we know exactly how many bytes to expect. -linearTransfer :: Stream s => s -> Int -> IO (Result ([Header],String)) -linearTransfer conn n - = do info <- readBlock conn n - return $ info `bindE` \str -> Right ([],str) - --- | Used when nothing about data is known, --- Unfortunately waiting for a socket closure --- causes bad behaviour. Here we just --- take data once and give up the rest. -hopefulTransfer :: Stream s => s -> String -> IO (Result ([Header],String)) -hopefulTransfer conn str - = readLine conn >>= - either (\v -> return $ Left v) - (\more -> if null more - then return (Right ([],str)) - else hopefulTransfer conn (str++more)) --- | A necessary feature of HTTP\/1.1 --- Also the only transfer variety likely to --- return any footers. -chunkedTransfer :: Stream s => s -> IO (Result ([Header],String)) -chunkedTransfer conn - = chunkedTransferC conn 0 >>= \v -> - return $ v `bindE` \(ftrs,c,info) -> - let myftrs = Header HdrContentLength (show c) : ftrs - in Right (myftrs,info) - -chunkedTransferC :: Stream s => s -> Int -> IO (Result ([Header],Int,String)) -chunkedTransferC conn n - = readLine conn >>= \v -> case v of - Left e -> return (Left e) - Right line -> - let size = ( if null line || (head line) == '0' - then 0 - else case readHex line of - (n',_):_ -> n' - _ -> 0 - ) - in if size == 0 - then do { rs <- readTillEmpty2 conn [] - ; return $ - rs `bindE` \strs -> - parseHeaders strs `bindE` \ftrs -> - Right (ftrs,n,"") - } - else do { some <- readBlock conn size - ; readLine conn - ; more <- chunkedTransferC conn (n+size) - ; return $ - some `bindE` \cdata -> - more `bindE` \(ftrs,m,mdata) -> - Right (ftrs,m,cdata++mdata) - } - --- | Maybe in the future we will have a sensible thing --- to do here, at that time we might want to change --- the name. -uglyDeathTransfer :: Stream s => s -> IO (Result ([Header],String)) -uglyDeathTransfer _ - = return $ Left $ ErrorParse "Unknown Transfer-Encoding" - --- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) -readTillEmpty1 :: Stream s => s -> IO (Result [String]) -readTillEmpty1 conn = - do { line <- readLine conn - ; case line of - Left e -> return $ Left e - Right s -> - if s == crlf - then readTillEmpty1 conn - else readTillEmpty2 conn [s] - } - --- | Read lines until an empty line (CRLF), --- also accepts a connection close as end of --- input, which is not an HTTP\/1.1 compliant --- thing to do - so probably indicates an --- error condition. -readTillEmpty2 :: Stream s => s -> [String] -> IO (Result [String]) -readTillEmpty2 conn list = - do { line <- readLine conn - ; case line of - Left e -> return $ Left e - Right s -> - if s == crlf || null s - then return (Right $ reverse (s:list)) - else readTillEmpty2 conn (s:list) - } - - ------------------------------------------------------------------ ------------------- A little friendly funtionality --------------- ------------------------------------------------------------------ - - -{- - I had a quick look around but couldn't find any RFC about - the encoding of data on the query string. I did find an - IETF memo, however, so this is how I justify the urlEncode - and urlDecode methods. - - Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org) - - Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved. - Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`" - URI delims: "<" | ">" | "#" | "%" | <"> - Unallowed ASCII: - - Also unallowed: any non-us-ascii character - - Escape method: char -> '%' a b where a, b :: Hex digits --} - -urlEncode, urlDecode :: String -> String - -urlDecode ('%':a:b:rest) = chr (16 * digitToInt a + digitToInt b) - : urlDecode rest -urlDecode (h:t) = h : urlDecode t -urlDecode [] = [] - -urlEncode (h:t) = - let str = if reserved_ (ord h) then escape h else [h] - in str ++ urlEncode t - where - reserved_ x - | x >= ord 'a' && x <= ord 'z' = False - | x >= ord 'A' && x <= ord 'Z' = False - | x >= ord '0' && x <= ord '9' = False - | x <= 0x20 || x >= 0x7F = True - | otherwise = x `elem` map ord [';','/','?',':','@','&' - ,'=','+',',','$','{','}' - ,'|','\\','^','[',']','`' - ,'<','>','#','%','"'] - -- wouldn't it be nice if the compiler - -- optimised the above for us? - - escape x = - let y = ord x - in [ '%', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ] - -urlEncode [] = [] - - - --- Encode form variables, useable in either the --- query part of a URI, or the body of a POST request. --- I have no source for this information except experience, --- this sort of encoding worked fine in CGI programming. -urlEncodeVars :: [(String,String)] -> String -urlEncodeVars ((n,v):t) = - let (same,diff) = partition ((==n) . fst) t - in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same) - ++ urlEncodeRest diff - where urlEncodeRest [] = [] - urlEncodeRest diff = '&' : urlEncodeVars diff -urlEncodeVars [] = [] diff --git a/src/Happstack/Server/HTTPClient/Stream.hs b/src/Happstack/Server/HTTPClient/Stream.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTPClient/Stream.hs +++ /dev/null @@ -1,173 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Happstack.Server.HTTPClient.Stream --- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004 --- License : BSD --- --- Maintainer : bjorn@bringert.net --- Stability : experimental --- Portability : non-portable (not tested) --- --- An library for creating abstract streams. Originally part of Gray's\/Bringert's --- HTTP module. --- --- * Changes by Simon Foster: --- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules --- ------------------------------------------------------------------------------ -module Happstack.Server.HTTPClient.Stream ( - -- ** Streams - Debug, - Stream(..), - debugStream, - - -- ** Errors - ConnError(..), - Result, - handleSocketError, - bindE, - myrecv - -) where - -import Control.Exception.Extensible as Exception -import System.IO.Error - --- Networking -import Network.Socket - -import Control.Monad (liftM) -import System.IO - -data ConnError = ErrorReset - | ErrorClosed - | ErrorParse String - | ErrorMisc String - deriving(Show,Eq) - --- error propagating: --- we could've used a monad, but that would lead us --- into using the "-fglasgow-exts" compile flag. -bindE :: Either ConnError a -> (a -> Either ConnError b) -> Either ConnError b -bindE (Left e) _ = Left e -bindE (Right v) f = f v - --- | This is the type returned by many exported network functions. -type Result a = Either ConnError {- error -} - a {- result -} - ------------------------------------------------------------------ ------------------- Gentle Art of Socket Sucking ----------------- ------------------------------------------------------------------ - --- | Streams should make layering of TLS protocol easier in future, --- they allow reading/writing to files etc for debugging, --- they allow use of protocols other than TCP/IP --- and they allow customisation. --- --- Instances of this class should not trim --- the input in any way, e.g. leave LF on line --- endings etc. Unless that is exactly the behaviour --- you want from your twisted instances ;) -class Stream x where - readLine :: x -> IO (Result String) - readBlock :: x -> Int -> IO (Result String) - writeBlock :: x -> String -> IO (Result ()) - close :: x -> IO () - - - - - --- Exception handler for socket operations -handleSocketError :: Socket -> Exception.SomeException -> IO (Result a) -handleSocketError sk e = - do { se <- getSocketOption sk SoError - ; if se == 0 - then throw e - else return $ if se == 10054 -- reset - then Left ErrorReset - else Left $ ErrorMisc $ show se - } - - - - -instance Stream Socket where - readBlock sk n = (liftM Right $ fn n) `Exception.catch` (handleSocketError sk) - where - fn x = do { str <- myrecv sk x - ; let len = length str - ; if len < x && len /= 0 - then ( fn (x-len) >>= \more -> return (str++more) ) - else return str - } - - -- Use of the following function is discouraged. - -- The function reads in one character at a time, - -- which causes many calls to the kernel recv() - -- hence causes many context switches. - readLine sk = (liftM Right $ fn "") `Exception.catch` (handleSocketError sk) - where - fn str = - do { c <- myrecv sk 1 -- like eating through a straw. - ; if null c || c == "\n" - then return (reverse str++c) - else fn (head c:str) - } - - writeBlock sk str = (liftM Right $ fn str) `Exception.catch` (handleSocketError sk) - where - fn [] = return () - fn x = send sk x >>= \i -> fn (drop i x) - - -- This slams closed the connection (which is considered rude for TCP\/IP) - close sk = shutdown sk ShutdownBoth >> sClose sk - -myrecv :: Socket -> Int -> IO String -myrecv sock len = - let handler e = if isEOFError e then return [] else ioError e - in System.IO.Error.catch (recv sock len) handler - --- | Allows stream logging. --- Refer to 'debugStream' below. -data Debug x = Dbg Handle x - - -instance (Stream x) => Stream (Debug x) where - readBlock (Dbg h c) n = - do { val <- readBlock c n - ; hPutStrLn h ("readBlock " ++ show n ++ ' ' : show val) - ; hFlush h - ; return val - } - - readLine (Dbg h c) = - do { val <- readLine c - ; hPutStrLn h ("readLine " ++ show val) - ; return val - } - - writeBlock (Dbg h c) str = - do { val <- writeBlock c str - ; hPutStrLn h ("writeBlock " ++ show val ++ ' ' : show str) - ; return val - } - - close (Dbg h c) = - do { hPutStrLn h "closing..." - ; hFlush h - ; close c - ; hPutStrLn h "...closed" - ; hClose h - } - - --- | Wraps a stream with logging I\/O, the first --- argument is a filename which is opened in AppendMode. -debugStream :: (Stream a) => String -> a -> IO (Debug a) -debugStream file stm = - do { h <- openFile file AppendMode - ; hPutStrLn h "File opened for appending." - ; return (Dbg h stm) - } diff --git a/src/Happstack/Server/HTTPClient/TCP.hs b/src/Happstack/Server/HTTPClient/TCP.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTPClient/TCP.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-} ------------------------------------------------------------------------------ --- | --- Module : Happstack.Server.HTTPClient.TCP --- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004 --- License : BSD --- --- Maintainer : bjorn@bringert.net --- Stability : experimental --- Portability : non-portable (not tested) --- --- An easy access TCP library. Makes the use of TCP in Haskell much easier. --- This was originally part of Gray's\/Bringert's HTTP module. --- --- * Changes by Simon Foster: --- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules --- ------------------------------------------------------------------------------ -module Happstack.Server.HTTPClient.TCP ( - -- ** Connections - Conn(..), - Connection(..), - openTCP, - openTCPPort, - isConnectedTo -) where - -import Control.Exception.Extensible as Exception - --- Networking -import Network.BSD -import Network.Socket -import Happstack.Server.HTTPClient.Stream - -import Data.List (elemIndex) -import Data.Char -import Data.IORef -import System.IO - ------------------------------------------------------------------ ------------------- TCP Connections ------------------------------ ------------------------------------------------------------------ - --- | The 'Connection' newtype is a wrapper that allows us to make --- connections an instance of the StreamIn\/Out classes, without ghc extensions. --- While this looks sort of like a generic reference to the transport --- layer it is actually TCP specific, which can be seen in the --- implementation of the 'Stream Connection' instance. -newtype Connection = ConnRef {getRef :: IORef Conn} - - --- | The 'Conn' object allows input buffering, and maintenance of --- some admin-type data. -data Conn = MkConn { connSock :: ! Socket - , connAddr :: ! SockAddr - , connBffr :: ! String - , connHost :: String - } - | ConnClosed - deriving(Eq) - - --- | Open a connection to port 80 on a remote host. -openTCP :: String -> IO Connection -openTCP host = openTCPPort host 80 - - --- | This function establishes a connection to a remote --- host, it uses "getHostByName" which interrogates the --- DNS system, hence may trigger a network connection. --- --- Add a "persistant" option? Current persistant is default. --- Use "Result" type for synchronous exception reporting? -openTCPPort :: String -> Int -> IO Connection -openTCPPort uri port = - do { s <- socket AF_INET Stream 6 - ; setSocketOption s KeepAlive 1 - ; host <- Exception.catch (inet_addr uri) -- handles ascii IP numbers - (\(_::SomeException) -> getHostByName uri >>= \host -> -- _shrug_ this will catch _any_ exception FIXME - case hostAddresses host of - [] -> return (error "no addresses in host entry") - (h:_) -> return h) - ; let a = SockAddrInet (toEnum port) host - ; Exception.catch (connect s a) (\(e::SomeException) -> sClose s >> throw e) - ; v <- newIORef (MkConn s a [] uri) - ; return (ConnRef v) - } - -instance Stream Connection where - readBlock ref n = - readIORef (getRef ref) >>= \conn -> case conn of - ConnClosed -> return (Left ErrorClosed) - (MkConn sk _addr bfr _hst) - | length bfr >= n -> - do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop n bfr) }) - ; return (Right $ take n bfr) - } - | otherwise -> - do { modifyIORef (getRef ref) (\c -> c { connBffr=[] }) - ; more <- readBlock sk (n - length bfr) - ; return $ case more of - Left _ -> more - Right s -> (Right $ bfr ++ s) - } - - -- This function uses a buffer, at this time the buffer is just 1000 characters. - -- (however many bytes this is is left to the user to decypher) - readLine ref = - readIORef (getRef ref) >>= \conn -> case conn of - ConnClosed -> return (Left ErrorClosed) - (MkConn sk _addr bfr _) - | null bfr -> {- read in buffer -} - do { str <- myrecv sk 1000 -- DON'T use "readBlock sk 1000" !! - -- ... since that call will loop. - ; let len = length str - ; if len == 0 {- indicates a closed connection -} - then return (Right "") - else modifyIORef (getRef ref) (\c -> c { connBffr=str }) - >> readLine ref -- recursion - } - | otherwise -> - case elemIndex '\n' bfr of - Nothing -> {- need recursion to finish line -} - do { modifyIORef (getRef ref) (\c -> c { connBffr=[] }) - ; more <- readLine ref -- contains extra recursion - ; return $ more `bindE` \str -> Right (bfr++str) - } - Just i -> {- end of line found -} - let (bgn,end) = splitAt i bfr in - do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop 1 end) }) - ; return (Right (bgn++['\n'])) - } - - - - -- The 'Connection' object allows no outward buffering, - -- since in general messages are serialised in their entirety. - writeBlock ref str = - readIORef (getRef ref) >>= \conn -> case conn of - ConnClosed -> return (Left ErrorClosed) - (MkConn sk addr _ _) -> fn sk addr str `Exception.catch` (handleSocketError sk) - where - fn sk addr s - | null s = return (Right ()) -- done - | otherwise = - getSocketOption sk SoError >>= \se -> - if se == 0 - then sendTo sk s addr >>= \i -> fn sk addr (drop i s) - else writeIORef (getRef ref) ConnClosed >> - if se == 10054 - then return (Left ErrorReset) - else return (Left $ ErrorMisc $ show se) - - - -- Closes a Connection. Connection will no longer - -- allow any of the other Stream functions. Notice that a Connection may close - -- at any time before a call to this function. This function is idempotent. - -- (I think the behaviour here is TCP specific) - close ref = - do { c <- readIORef (getRef ref) - ; closeConn c `Exception.catch` (\(_::SomeException) -> return ()) -- FIXME see above - ; writeIORef (getRef ref) ConnClosed - } - where - -- Be kind to peer & close gracefully. - closeConn (ConnClosed) = return () - closeConn (MkConn sk _addr [] _) = - do { shutdown sk ShutdownSend - ; suck ref - ; shutdown sk ShutdownReceive - ; sClose sk - } - closeConn (MkConn _ _ _ _) = error "Case in closeConn not supported" - - suck :: Connection -> IO () - suck cn = readLine cn >>= - either (\_ -> return ()) -- catch errors & ignore - (\x -> if null x then return () else suck cn) - --- | Checks both that the underlying Socket is connected --- and that the connection peer matches the given --- host name (which is recorded locally). -isConnectedTo :: Connection -> String -> IO Bool -isConnectedTo conn name = - do { v <- readIORef (getRef conn) - ; case v of - ConnClosed -> return False - (MkConn sk _ _ h) -> - if (map toLower h == map toLower name) - then sIsConnected sk - else return False - } - diff --git a/src/Happstack/Server/I18N.hs b/src/Happstack/Server/I18N.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/I18N.hs @@ -0,0 +1,52 @@ +module Happstack.Server.I18N + ( acceptLanguage + , bestLanguage + ) where + +import Control.Arrow ((>>>), first, second) +import Data.Function (on) +import qualified Data.ByteString.Char8 as C +import Data.List (sortBy) +import Data.Maybe (fromMaybe) +import Data.Text as Text (Text, breakOnAll, pack, singleton) +import Happstack.Server.Monads (Happstack, getHeaderM) +import Happstack.Server.Internal.Compression (encodings) +import Text.ParserCombinators.Parsec (parse) + +-- TODO: proper Accept-Language parser + +-- | parse the 'Accept-Language' header, or [] if not found. +acceptLanguage :: (Happstack m) => m [(Text, Maybe Double)] +acceptLanguage = + do mAcceptLanguage <- (fmap C.unpack) <$> getHeaderM "Accept-Language" + case mAcceptLanguage of + Nothing -> return [] + (Just al) -> + case parse encodings al al of + (Left _) -> return [] + (Right encs) -> return (map (first Text.pack) encs) + +-- | deconstruct the 'acceptLanguage' results a return a list of +-- languages sorted by preference in descending order. +-- +-- Note: this implementation does not conform to RFC4647 +-- +-- Among other things, it does not handle wildcards. A proper +-- implementation needs to take a list of available languages. +bestLanguage :: [(Text, Maybe Double)] -> [Text] +bestLanguage range = + -- is no 'q' param, set 'q' to 1.0 + map (second $ fromMaybe 1) >>> + -- sort in descending order + sortBy (flip compare `on` snd) >>> + -- remove entries with '*' or q == 0. Removing '*' entries is not + -- technically correct, but it is the best we can do with out a + -- list of available languages. + filter (\(lang, q) -> lang /= (Text.singleton '*') && q > 0) >>> + -- lookup fallback (RFC 4647, Section 3.4) + concatMap (explode . fst) $ + range + where + -- | example: "en-us-gb" -> ["en-us-gb","en-us","en"] + explode :: Text -> [Text] + explode lang = lang : (reverse $ map fst $ breakOnAll (singleton '-') lang) diff --git a/src/Happstack/Server/Internal/Clock.hs b/src/Happstack/Server/Internal/Clock.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/Clock.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS -fno-cse #-} +module Happstack.Server.Internal.Clock + ( getApproximateTime + , getApproximatePOSIXTime + , getApproximateUTCTime + , formatHttpDate + ) where + +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, defaultTimeLocale) +import System.IO.Unsafe + +data DateCache = DateCache { + cachedPOSIXTime :: !(IORef POSIXTime) + , cachedHttpDate :: !(IORef B.ByteString) + } + +formatHttpDate :: UTCTime -> String +formatHttpDate = formatTime defaultTimeLocale "%a, %d %b %Y %X GMT" +{-# INLINE formatHttpDate #-} + +mkTime :: IO (POSIXTime, B.ByteString) +mkTime = + do now <- getPOSIXTime + return (now, B.pack $ formatHttpDate (posixSecondsToUTCTime now)) + +{-# NOINLINE clock #-} +clock :: DateCache +clock = unsafePerformIO $ do + (now, httpDate) <- mkTime + nowRef <- newIORef now + httpDateRef <- newIORef httpDate + let dateCache = (DateCache nowRef httpDateRef) + void $ forkIO $ updater dateCache + return dateCache + +updater :: DateCache -> IO () +updater dateCache = + do threadDelay (10^(6 :: Int)) -- Every second + (now, httpDate) <- mkTime + writeIORef (cachedPOSIXTime dateCache) now + writeIORef (cachedHttpDate dateCache) httpDate + updater dateCache + +getApproximateTime :: IO B.ByteString +getApproximateTime = readIORef (cachedHttpDate clock) + +getApproximatePOSIXTime :: IO POSIXTime +getApproximatePOSIXTime = readIORef (cachedPOSIXTime clock) + +getApproximateUTCTime :: IO UTCTime +getApproximateUTCTime = posixSecondsToUTCTime <$> getApproximatePOSIXTime diff --git a/src/Happstack/Server/Internal/Compression.hs b/src/Happstack/Server/Internal/Compression.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/Compression.hs @@ -0,0 +1,276 @@ +{-# 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 +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Codec.Compression.GZip as GZ +import qualified Codec.Compression.Zlib as Z + +-- | 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, 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) + + where + badEncoding = "Encoding returned not in the list of known encodings" + + installHandler accept = do + let eEncoding = bestEncoding (map fst encodingHandlers) $ BS.unpack accept + (coding, identityAllowed, action) <- case eEncoding of + Left _ -> do + setResponseCode 406 + finishWith $ toResponse "" + + Right encs@(a:_) -> return (a + , "identity" `elem` encs + , fromMaybe (\ _ _ -> fail badEncoding) + (lookup a encodingHandlers) + ) + Right [] -> fail badEncoding + action coding identityAllowed + return coding + +-- | Ignore the @Accept-Encoding@ header in the 'Request' and attempt to compress the body of the response with @gzip@. +-- +-- calls 'compressWithFilter' using 'GZ.compress'. +-- +-- see also: 'compressedResponseFilter' +gzipFilter::(FilterMonad Response m) => + String -- ^ encoding to use for Content-Encoding header + -> Bool -- ^ fallback to identity for SendFile + -> m () +gzipFilter = compressWithFilter GZ.compress + +-- | Ignore the @Accept-Encoding@ header in the 'Request' and attempt compress the body of the response with zlib's +-- @deflate@ method +-- +-- calls 'compressWithFilter' using 'Z.compress'. +-- +-- see also: 'compressedResponseFilter' +deflateFilter::(FilterMonad Response m) => + String -- ^ encoding to use for Content-Encoding header + -> Bool -- ^ fallback to identity for SendFile + -> 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@. +-- +-- 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 + -> Bool -- ^ fallback to identity for SendFile + -> m () +compressWithFilter compressor encoding identityAllowed = + composeFilter $ \r -> + case r of + Response{} -> setHeader "Content-Encoding" encoding $ + setHeader "Vary" "Accept-Encoding" $ + r {rsBody = compressor $ rsBody r} + _ | identityAllowed -> r + | otherwise -> (toResponse "") { rsCode = 406 } + +-- | based on the rules describe in rfc2616 sec. 14.3 +bestEncoding :: [String] -> String -> Either String [String] +bestEncoding availableEncodings encs = do + encList<-either (Left . show) (Right) $ parse encodings "" encs + case acceptable encList of + [] -> Left "no encoding found" + a -> Right $ a + where + -- first intersect with the list of encodings we know how to deal with at all + knownEncodings:: [(String,Maybe Double)] -> [(String, Maybe Double)] + knownEncodings m = intersectBy (\x y->fst x == fst y) m (map (\x -> (x,Nothing)) availableEncodings) + -- this expands the wildcard, by figuring out if we need to include "identity" in the list + -- Then it deletes the wildcard entry, drops all the "q=0" entries (which aren't allowed). + -- + -- note this implementation is a little conservative. if someone were to specify "*" + -- without a "q" value, it would be this server is willing to accept any format at all. + -- We pretty much assume we can't send them /any/ format and that they really + -- meant just "identity" this seems safe to me. + knownEncodings':: [(String,Maybe Double)] -> [(String, Maybe Double)] + knownEncodings' m = filter dropZero $ deleteBy (\(a,_) (b,_)->a==b) ("*",Nothing) $ + case lookup "*" (knownEncodings m) of + Nothing -> addIdent $ knownEncodings m + Just (Just a) | a>0 -> addIdent $ knownEncodings m + | otherwise -> knownEncodings m + Just (Nothing) -> addIdent $ knownEncodings m + dropZero (_, Just a) | a==0 = False + | otherwise = True + dropZero (_, Nothing) = True + addIdent:: [(String,Maybe Double)] -> [(String, Maybe Double)] + addIdent m = if isNothing $ lookup "identity" m + then m ++ [("identity",Nothing)] + else m + -- finally we sort the list of available encodings. + acceptable:: [(String,Maybe Double)] -> [String] + acceptable l = map fst $ sortBy (flip cmp) $ knownEncodings' l + -- let the client choose but break ties with gzip + encOrder = reverse $ zip (reverse availableEncodings) [1..] + m0 = maybe (0.0::Double) id + cmp (s,mI) (t,mJ) | m0 mI == m0 mJ + = compare (m0 $ lookup s encOrder) (m0 $ lookup t encOrder) + | otherwise = compare (m0 mI) (m0 mJ) + + +-- | 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 + +standardEncodings :: [String] +standardEncodings = + ["gzip" + ,"x-gzip" +-- ,"compress" -- as far as I can tell there is no haskell library that supports this +-- ,"x-compress" -- as far as I can tell, there is no haskell library that supports this + ,"deflate" + ,"identity" + ,"*" + ] + +handlers::(FilterMonad Response m, MonadFail m) => [String -> Bool -> m ()] +handlers = + [ gzipFilter + , gzipFilter +-- ,compressFilter +-- ,compressFilter + , deflateFilter + , identityFilter + , starFilter + ] + +-- | a parser for the Accept-Encoding header +encodings :: GenParser Char st [(String, Maybe Double)] +encodings = ws >> (encoding1 `sepBy` try sep) >>= (\x -> ws >> eof >> return x) + where + ws :: GenParser Char st () + ws = many space >> return () + + sep :: GenParser Char st () + sep = do + ws + _ <- char ',' + ws + + encoding1 :: GenParser Char st ([Char], Maybe Double) + encoding1 = do + encoding <- many1 (alphaNum <|> char '-') <|> string "*" + ws + quality<-optionMaybe qual + return (encoding, fmap read quality) + + qual :: GenParser Char st String + qual = do + char ';' >> ws >> char 'q' >> ws >> char '=' >> ws + q<-float + return q + + int :: GenParser Char st String + int = many1 digit + + float :: GenParser Char st String + float = do + wholePart<-many1 digit + fractionalPart<-option "" fraction + return $ wholePart ++ fractionalPart + <|> + do + fractionalPart<-fraction + return fractionalPart + fraction :: GenParser Char st String + fraction = do + _ <- char '.' + fractionalPart<-option "" int + return $ '.':fractionalPart diff --git a/src/Happstack/Server/Internal/Cookie.hs b/src/Happstack/Server/Internal/Cookie.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/Cookie.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +-- http://tools.ietf.org/html/rfc2109 +module Happstack.Server.Internal.Cookie + ( Cookie(..) + , CookieLife(..) + , SameSite(..) + , calcLife + , mkCookie + , mkCookieHeader + , getCookies + , getCookie + , getCookies' + , getCookie' + , parseCookies + , cookiesParser + ) + 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) +import Data.List ((\\), intersperse) +import Data.Time.Clock (UTCTime, addUTCTime, diffUTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.Format (formatTime, defaultTimeLocale) +import Happstack.Server.Internal.Clock (getApproximateUTCTime) +import Network.URI (escapeURIString) +import Text.ParserCombinators.Parsec hiding (token) + + + + +-- | a type for HTTP cookies. Usually created using 'mkCookie'. +data Cookie = Cookie + { cookieVersion :: String + , cookiePath :: String + , cookieDomain :: String + , cookieName :: String + , cookieValue :: String + , secure :: Bool + , httpOnly :: Bool + , sameSite :: SameSite + , partitioned :: Bool + } deriving (Show, Eq, Read, Data) + +-- | Specify the lifetime of a cookie. +-- +-- Note that we always set the max-age and expires headers because +-- internet explorer does not honor max-age. You can specific 'MaxAge' +-- or 'Expires' and the other will be calculated for you. Choose which +-- ever one makes your life easiest. +-- +data CookieLife + = Session -- ^ session cookie - expires when browser is closed + | MaxAge Int -- ^ life time of cookie in seconds + | Expires UTCTime -- ^ cookie expiration date + | Expired -- ^ cookie already expired + 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 +calcLife (MaxAge s) = + do now <- getApproximateUTCTime + return (Just (s, addUTCTime (fromIntegral s) now)) +calcLife (Expires expirationDate) = + do now <- getApproximateUTCTime + return $ Just (round $ expirationDate `diffUTCTime` now, expirationDate) +calcLife Expired = + return $ Just (0, posixSecondsToUTCTime 0) + + +-- | Creates a cookie with a default version of 1, empty domain, a +-- 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 SameSiteNoValue False + +-- | Set a Cookie in the Result. +-- The values are escaped as per RFC 2109, but some browsers may +-- have buggy support for cookies containing e.g. @\'\"\'@ or @\' \'@. +-- +-- Also, it seems that chrome, safari, and other webkit browsers do +-- not like cookies which have double quotes around the domain and +-- reject/ignore the cookie. So, we no longer quote the domain. +-- +-- internet explorer does not honor the max-age directive so we set +-- both max-age and expires. +-- +-- See 'CookieLife' and 'calcLife' for a convenient way of calculating +-- 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' . 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 +parseCookies :: String -> Either String [Cookie] +parseCookies str = either (Left . show) Right $ parse cookiesParser str str + +-- | not a supported api. A parser for RFC 2109 cookies +cookiesParser :: GenParser Char st [Cookie] +cookiesParser = cookies + where -- Parsers based on RFC 2109 + cookies = do + ws + ver<-option "" $ try (cookie_version >>= (\x -> cookieSep >> return x)) + cookieList<-(cookie_value ver) `sepBy1` try cookieSep + ws + eof + return cookieList + cookie_value ver = do + name<-name_parser + cookieEq + val<-value + path<-option "" $ try (cookieSep >> cookie_path) + domain<-option "" $ try (cookieSep >> cookie_domain) + 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" + cookie_special s = do + void $ string s + cookieEq + value + cookieSep = ws >> oneOf ",;" >> ws + cookieEq = ws >> char '=' >> ws + ws = spaces + value = word + word = try quoted_string <|> try incomp_token <|> return "" + + -- Parsers based on RFC 2068 + quoted_string = do + void $ char '"' + r <-many ((try quotedPair) <|> (oneOf qdtext)) + void $ char '"' + return r + + -- Custom parsers, incompatible with RFC 2068, but more forgiving ;) + incomp_token = many1 $ oneOf ((chars \\ ctl) \\ " \t\";") + name_parser = many1 $ oneOf ((chars \\ ctl) \\ "= ;,") + + -- Primitives from RFC 2068 + ctl = map chr (127:[0..31]) + chars = map chr [0..127] + octet = map chr [0..255] + text = octet \\ ctl + qdtext = text \\ "\"" + quotedPair = char '\\' >> anyChar + +-- | 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 :: 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 :: 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]) +getCookies' header | C.null header = return $ Right [] + | otherwise = return $ parseCookies (C.unpack header) + +getCookie' :: Monad m => String -> C.ByteString -> m (Either String Cookie) +getCookie' s h = do + cs <- getCookies' h + return $ do -- Either + cooks <- cs + case filter (\x->(==) (low s) (cookieName x) ) cooks of + [] -> 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 new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/Handler.hs @@ -0,0 +1,404 @@ +{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables, TupleSections #-} + +module Happstack.Server.Internal.Handler + ( request + , parseResponse + , putRequest + ) where + +import qualified Paths_happstack_server as Paths +import qualified Data.Version as DV +import Control.Applicative (pure) +import Control.Concurrent (newMVar, newEmptyMVar, tryTakeMVar) +import Control.Exception.Extensible as E +import Control.Monad +import Data.List(elemIndex) +import Data.Char(toLower) +import Data.Maybe ( fromMaybe, fromJust, isJust, isNothing ) +import Data.Time (UTCTime) +import Prelude hiding (last) +import qualified Data.ByteString.Char8 as P +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as L +import Data.ByteString.Lazy.Internal (ByteString(Chunk, Empty)) +import qualified Data.ByteString.Lazy.Char8 as LC +import qualified Data.Map as M +import Data.Int (Int64) +import Happstack.Server.Internal.Cookie +import Happstack.Server.Internal.Clock +import Happstack.Server.Internal.Types +import Happstack.Server.Internal.Multipart +import Happstack.Server.Internal.RFC822Headers +import Happstack.Server.Internal.MessageWrap +import Happstack.Server.SURI(SURI(..),path,query) +import Happstack.Server.SURI.ParseURI +import Happstack.Server.Internal.TimeoutIO (TimeoutIO(..)) +import Happstack.Server.Internal.Monads (failResponse) +import qualified Happstack.Server.Internal.TimeoutManager as TM +import Numeric +import System.Directory (removeFile) +import System.IO +import System.IO.Error (isDoesNotExistError) + +request :: TimeoutIO -> Maybe (LogAccess UTCTime) -> Host -> (Request -> IO Response) -> IO () +request timeoutIO mlog host handler = + rloop timeoutIO mlog host handler =<< toGetContents timeoutIO + +required :: String -> Maybe a -> Either String a +required err Nothing = Left err +required _ (Just a) = Right a + +rloop :: TimeoutIO + -> Maybe (LogAccess UTCTime) + -> Host + -> (Request -> IO Response) + -> L.ByteString + -> IO () +rloop timeoutIO mlog host handler inputStr + | L.null inputStr = return () + | otherwise + = (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' <- 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 -> Left "negative content-length" + | isJust $ getHeaderBS transferEncodingC headers -> + return $ consumeChunks restStr + | otherwise -> return (L.splitAt (fromIntegral contentLen) restStr) + let cookies = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" headers)), c <- cl ] -- Ugle + return (m, u, cookies, v, headers, body, nextRequest) + + case parseRequest of + Left err -> error $ "failed to parse HTTP request: " ++ err + Right (m, u, cookies, v, headers, body, nextRequest) + -> pure $ + do bodyRef <- newMVar (Body body) + bodyInputRef <- newEmptyMVar + let req = Request (toSecure timeoutIO) m (pathEls (path u)) (path u) (query u) + (queryInput u) bodyInputRef cookies v headers bodyRef host + + let ioseq act = act >>= \x -> x `seq` return x + + (res, handlerKilled) <- ((, False) `liftM` ioseq (handler req)) + `E.catches` [ Handler $ \(e::EscapeHTTP) -> throwIO e -- need to handle this higher up + , Handler $ \(e::E.SomeException) -> pure (failResponse (show e), fromException e == Just ThreadKilled) + ] + + case mlog of + Nothing -> return () + (Just logger) -> + do time <- getApproximateUTCTime + let host' = fst host + user = "-" + requestLn = unwords [show $ rqMethod req, rqUri req, show $ rqVersion req] + responseCode = rsCode res + size = maybe (-1) (readDec' . B.unpack) (getHeader "Content-Length" res) -- -1 indicates unknown size + referer = B.unpack $ fromMaybe (B.pack "") $ getHeader "Referer" req + userAgent = B.unpack $ fromMaybe (B.pack "") $ getHeader "User-Agent" req + logger host' user time requestLn responseCode size referer userAgent + + -- withNoPush sock $ putAugmentedResult thandle sock req res + putAugmentedResult timeoutIO req res + -- clean up tmp files + cleanupTempFiles req + -- do not continue if handler was killed + when (not handlerKilled && continueHTTP req res) $ + rloop timeoutIO mlog host handler nextRequest) `E.catch` (escapeHttpHandler timeoutIO) + +escapeHttpHandler :: TimeoutIO + -> EscapeHTTP + -> IO () +escapeHttpHandler tio (EscapeHTTP f) = f tio + +-- NOTE: if someone took the inputs and never put them back, then they are responsible for the cleanup +cleanupTempFiles :: Request -> IO () +cleanupTempFiles req = + do mInputs <- tryTakeMVar (rqInputsBody req) + case mInputs of + Nothing -> return () + (Just inputs) -> mapM_ deleteTmpFile inputs + where + deleteTmpFile :: (String, Input) -> IO () + deleteTmpFile (_, input) = + case inputValue input of + (Left fp) -> E.catchJust (guard . isDoesNotExistError) (removeFile fp) (const $ return ()) + _ -> return () + +-- | Unserializes the bytestring into a response. If there is an +-- error it will return @Left msg@. +parseResponse :: L.ByteString -> Either String Response +parseResponse inputStr = + do (topStr,restStr) <- required "failed to separate response" $ + splitAtEmptyLine inputStr + (rsl,headerStr) <- required "failed to separate headers/body" $ + splitAtCRLF topStr + let (_,code) = responseLine rsl + 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,_) <- + maybe (if (isNothing $ getHeader "transfer-encoding" headers) + then return (restStr,L.pack "") + else return $ consumeChunks restStr) + (\cl->return (L.splitAt (fromIntegral cl) restStr)) + mbCL + return $ Response {rsCode=code,rsHeaders=headers,rsBody=body,rsFlags=RsFlags ContentLength,rsValidator=Nothing} + +-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html +-- note this does NOT handle extenions +consumeChunks::L.ByteString->(L.ByteString,L.ByteString) +consumeChunks str = let (parts,tr,rest) = consumeChunksImpl str in (L.concat . (++ [tr]) .map snd $ parts,rest) + +consumeChunksImpl :: L.ByteString -> ([(Int64, L.ByteString)], L.ByteString, L.ByteString) +consumeChunksImpl str + | L.null str = ([],L.empty,str) + | chunkLen == 0 = let (last,rest') = L.splitAt lenLine1 str + (tr',rest'') = getTrailer rest' + in ([(0,last)],tr',rest'') + | otherwise = ((chunkLen,part):crest,tr,rest2) + where + line1 = head $ lazylines str + lenLine1 = (L.length line1) + 1 -- endchar + chunkLen = (fst $ head $ readHex $ L.unpack line1) + len = chunkLen + lenLine1 + 2 + (part,rest) = L.splitAt len str + (crest,tr,rest2) = consumeChunksImpl rest + getTrailer s = L.splitAt index s + where index | crlfLC `L.isPrefixOf` s = 2 + | otherwise = let iscrlf = L.zipWith (\a b -> a == '\r' && b == '\n') s . L.tail $ s + Just i = elemIndex True $ zipWith (&&) iscrlf (tail (tail iscrlf)) + in fromIntegral $ i+4 + +crlfLC :: L.ByteString +crlfLC = L.pack "\r\n" + +-- Properly lazy version of 'lines' for lazy bytestrings +lazylines :: L.ByteString -> [L.ByteString] +lazylines s + | L.null s = [] + | otherwise = + let (l,s') = L.break ((==) '\n') s + in l : if L.null s' then [] + else lazylines (L.tail s') + +requestLine :: L.ByteString -> (Method, SURI, HttpVersion) +requestLine l = case P.words ((P.concat . L.toChunks) l) of + [rq,uri,ver] -> (method rq, SURI $ parseURIRef uri, version ver) + [rq,uri] -> (method rq, SURI $ parseURIRef uri,HttpVersion 0 9) + x -> error $ "requestLine cannot handle input: " ++ (show x) + +responseLine :: L.ByteString -> (B.ByteString, Int) +responseLine l = case B.words ((B.concat . L.toChunks) l) of + (v:c:_) -> version v `seq` (v,fst (fromJust (B.readInt c))) + x -> error $ "responseLine cannot handle input: " ++ (show x) + + +method :: B.ByteString -> Method +method r = fj $ lookup r mtable + where fj (Just x) = x + 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 + +staticHeaders :: Headers +staticHeaders = + foldr (uncurry setHeaderBS) (mkHeaders []) + [ (serverC, happstackC) ] + +-- FIXME: we should not be controlling the response headers in mysterious ways in this low level code +-- headers should be set by application code and the core http engine should be very lean. +putAugmentedResult :: TimeoutIO -> Request -> Response -> IO () +putAugmentedResult timeoutIO req res = do + case res of + -- standard bytestring response + Response {} -> do + let isChunked = rsfLength (rsFlags res) == TransferEncodingChunked && isHTTP1_1 req + sendTop (if isChunked then Nothing else (Just (fromIntegral (L.length (rsBody res))))) isChunked + when (rqMethod req /= HEAD) + (let body = if isChunked + then chunk (rsBody res) + else rsBody res + in toPutLazy timeoutIO body) + -- zero-copy sendfile response + -- the handle *should* be closed by the garbage collector + + SendFile {} -> do + let infp = sfFilePath res + off = sfOffset res + count = sfCount res + sendTop (Just count) False + TM.tickle (toHandle timeoutIO) + toSendFile timeoutIO infp off count + + where ph (HeaderPair k vs) = map (\v -> P.concat [k, fsepC, v, crlfC]) vs + sendTop cl isChunked = do + allHeaders <- augmentHeaders req res cl isChunked + toPut timeoutIO $ B.concat $ concat + [ (pversion $ rqVersion req) -- Print HTTP version + , [responseMessage $ rsCode res] -- Print responseCode + , concatMap ph (M.elems allHeaders) -- Print all headers + , [crlfC] + ] + TM.tickle (toHandle timeoutIO) + chunk :: L.ByteString -> L.ByteString + chunk Empty = LC.pack "0\r\n\r\n" + chunk (Chunk c cs) = Chunk (B.pack $ showHex (B.length c) "\r\n") (Chunk c (Chunk (B.pack "\r\n") (chunk cs))) + +augmentHeaders :: Request -> Response -> Maybe Integer -> Bool -> IO Headers +augmentHeaders req res mcl isChunked = do + -- TODO: Hoist static headers to the toplevel. + raw <- getApproximateTime + let stdHeaders = staticHeaders `M.union` + M.fromList ( [ (dateCLower, HeaderPair dateC [raw]) + , (connectionCLower, HeaderPair connectionC [if continueHTTP req res then keepAliveC else closeC]) + ] ++ case rsfLength (rsFlags res) of + NoContentLength -> [] + ContentLength | not (hasHeader "Content-Length" res) -> + case mcl of + (Just cl) -> [(contentlengthC, HeaderPair contentLengthC [P.pack (show cl)])] + _ -> [] + | otherwise -> [] + TransferEncodingChunked + -- we check 'chunked' because we might not use this mode if the client is http 1.0 + | isChunked -> [(transferEncodingC, HeaderPair transferEncodingC [chunkedC])] + | otherwise -> [] + + ) + return (rsHeaders res `M.union` stdHeaders) -- 'union' prefers 'headers res' when duplicate keys are encountered. + +-- | Serializes the request to the given handle +putRequest :: Handle -> Request -> IO () +putRequest h rq = do + let put = B.hPut h + ph (HeaderPair k vs) = map (\v -> B.concat [k, fsepC, v, crlfC]) vs + sp = [B.pack " "] + mapM_ put $ concat + [[B.pack $ show $ rqMethod rq],sp + ,[B.pack $ rqURL rq],sp + ,(pversion $ rqVersion rq), [crlfC] + ,concatMap ph (M.elems $ rqHeaders rq) + ,[crlfC] + ] + mBody <- takeRequestBody rq -- tryTakeMVar (rqBody rq) + L.hPut h (maybe L.empty unBody mBody) -- FIXME: should this actually be an error if the body is null? + hFlush h + +-- HttpVersion + +pversion :: HttpVersion -> [B.ByteString] +pversion (HttpVersion 1 1) = [http11] +pversion (HttpVersion 1 0) = [http10] +pversion (HttpVersion x y) = [P.pack "HTTP/", P.pack (show x), P.pack ".", P.pack (show y)] + +version :: B.ByteString -> HttpVersion +version x | x == http09 = HttpVersion 0 9 + | x == http10 = HttpVersion 1 0 + | x == http11 = HttpVersion 1 1 + | otherwise = error "Invalid HTTP version" + +http09 :: B.ByteString +http09 = P.pack "HTTP/0.9" +http10 :: B.ByteString +http10 = P.pack "HTTP/1.0" +http11 :: B.ByteString +http11 = P.pack "HTTP/1.1" + +-- * ByteString Constants + +connectionC :: B.ByteString +connectionC = P.pack "Connection" +connectionCLower :: B.ByteString +connectionCLower = P.map toLower connectionC +closeC :: B.ByteString +closeC = P.pack "close" +keepAliveC :: B.ByteString +keepAliveC = P.pack "Keep-Alive" +crlfC :: B.ByteString +crlfC = P.pack "\r\n" +fsepC :: B.ByteString +fsepC = P.pack ": " +-- contentTypeC :: B.ByteString +-- contentTypeC = P.pack "Content-Type" +contentLengthC :: B.ByteString +contentLengthC = P.pack "Content-Length" +contentlengthC :: B.ByteString +contentlengthC = P.pack "content-length" +dateC :: B.ByteString +dateC = P.pack "Date" +dateCLower :: B.ByteString +dateCLower = P.map toLower dateC +serverC :: B.ByteString +serverC = P.pack "Server" +happstackC :: B.ByteString +happstackC = P.pack $ "Happstack/" ++ DV.showVersion Paths.version +-- textHtmlC :: B.ByteString +-- textHtmlC = P.pack "text/html; charset=utf-8" +transferEncodingC :: B.ByteString +transferEncodingC = P.pack "Transfer-Encoding" +chunkedC :: B.ByteString +chunkedC = P.pack "chunked" + +-- Response code names + +responseMessage :: (Num t, Show t, Eq t) => t -> B.ByteString +responseMessage 100 = P.pack " 100 Continue\r\n" +responseMessage 101 = P.pack " 101 Switching Protocols\r\n" +responseMessage 200 = P.pack " 200 OK\r\n" +responseMessage 201 = P.pack " 201 Created\r\n" +responseMessage 202 = P.pack " 202 Accepted\r\n" +responseMessage 203 = P.pack " 203 Non-Authoritative Information\r\n" +responseMessage 204 = P.pack " 204 No Content\r\n" +responseMessage 205 = P.pack " 205 Reset Content\r\n" +responseMessage 206 = P.pack " 206 Partial Content\r\n" +responseMessage 300 = P.pack " 300 Multiple Choices\r\n" +responseMessage 301 = P.pack " 301 Moved Permanently\r\n" +responseMessage 302 = P.pack " 302 Found\r\n" +responseMessage 303 = P.pack " 303 See Other\r\n" +responseMessage 304 = P.pack " 304 Not Modified\r\n" +responseMessage 305 = P.pack " 305 Use Proxy\r\n" +responseMessage 307 = P.pack " 307 Temporary Redirect\r\n" +responseMessage 400 = P.pack " 400 Bad Request\r\n" +responseMessage 401 = P.pack " 401 Unauthorized\r\n" +responseMessage 402 = P.pack " 402 Payment Required\r\n" +responseMessage 403 = P.pack " 403 Forbidden\r\n" +responseMessage 404 = P.pack " 404 Not Found\r\n" +responseMessage 405 = P.pack " 405 Method Not Allowed\r\n" +responseMessage 406 = P.pack " 406 Not Acceptable\r\n" +responseMessage 407 = P.pack " 407 Proxy Authentication Required\r\n" +responseMessage 408 = P.pack " 408 Request Time-out\r\n" +responseMessage 409 = P.pack " 409 Conflict\r\n" +responseMessage 410 = P.pack " 410 Gone\r\n" +responseMessage 411 = P.pack " 411 Length Required\r\n" +responseMessage 412 = P.pack " 412 Precondition Failed\r\n" +responseMessage 413 = P.pack " 413 Request Entity Too Large\r\n" +responseMessage 414 = P.pack " 414 Request-URI Too Large\r\n" +responseMessage 415 = P.pack " 415 Unsupported Media Type\r\n" +responseMessage 416 = P.pack " 416 Requested range not satisfiable\r\n" +responseMessage 417 = P.pack " 417 Expectation Failed\r\n" +responseMessage 500 = P.pack " 500 Internal Server Error\r\n" +responseMessage 501 = P.pack " 501 Not Implemented\r\n" +responseMessage 502 = P.pack " 502 Bad Gateway\r\n" +responseMessage 503 = P.pack " 503 Service Unavailable\r\n" +responseMessage 504 = P.pack " 504 Gateway Time-out\r\n" +responseMessage 505 = P.pack " 505 HTTP Version not supported\r\n" +responseMessage x = P.pack (" " ++ show x ++ " \r\n") diff --git a/src/Happstack/Server/Internal/LazyLiner.hs b/src/Happstack/Server/Internal/LazyLiner.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/LazyLiner.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Happstack.Server.Internal.LazyLiner + (Lazy, newLinerHandle, headerLines, getBytes, getBytesStrict, getRest, L.toChunks + ) where + +import Control.Concurrent.MVar +import System.IO +import qualified Data.ByteString.Char8 as P +import qualified Data.ByteString.Lazy.Char8 as L + +newtype Lazy = Lazy (MVar L.ByteString) + +newLinerHandle :: Handle -> IO Lazy +newLinerHandle h = fmap Lazy (newMVar =<< L.hGetContents h) + +headerLines :: Lazy -> IO [P.ByteString] +headerLines (Lazy mv) = modifyMVar mv $ \l -> do + let loop acc r0 = let (h,r) = L.break ((==) ch) r0 + ph = toStrict h + phl = P.length ph + ph2 = if phl == 0 || P.last ph /= '\x0D' then ph else P.init ph + ch = '\x0A' + r' = if L.null r then r else L.tail r + in if P.length ph2 == 0 then (r', reverse acc) else loop (ph2:acc) r' + return $ loop [] l + +getBytesStrict :: Lazy -> Int -> IO P.ByteString +getBytesStrict (Lazy mv) len = modifyMVar mv $ \l -> do + let (h,p) = L.splitAt (fromIntegral len) l + return (p, toStrict h) + +getBytes :: Lazy -> Int -> IO L.ByteString +getBytes (Lazy mv) len = modifyMVar mv $ \l -> do + let (h,p) = L.splitAt (fromIntegral len) l + return (p, h) + +getRest :: Lazy -> IO L.ByteString +getRest (Lazy mv) = modifyMVar mv $ \l -> return (L.empty, l) + +toStrict :: L.ByteString -> P.ByteString +toStrict = P.concat . L.toChunks diff --git a/src/Happstack/Server/Internal/Listen.hs b/src/Happstack/Server/Internal/Listen.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/Listen.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} +module Happstack.Server.Internal.Listen(listen, listen',listenOn,listenOnIPv4) where + +import Data.Maybe (isNothing) +import Happstack.Server.Internal.Types (Conf(..), Request, Response) +import Happstack.Server.Internal.Handler (request) +import Happstack.Server.Internal.Socket (acceptLite) +import Happstack.Server.Internal.TimeoutManager (cancel, initialize, register, forceTimeoutAll) +import Happstack.Server.Internal.TimeoutSocket as TS +import qualified Control.Concurrent.Thread.Group as TG +import Control.Exception.Extensible as E +import Control.Concurrent (forkIO, killThread, myThreadId) +import Control.Monad +import qualified Data.Maybe as Maybe +import qualified Network.Socket as Socket +import System.IO.Error (isFullError) +import Foreign.C (CInt) +{- +#ifndef mingw32_HOST_OS +-} +import System.Posix.Signals +{- +#endif +-} +import System.Log.Logger (Priority(..), logM) +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, + depending on system and local settings. + Lets make it use IPv4 only for now. +-} + +listenOn :: Int -> IO Socket.Socket +listenOn portm = do + E.bracketOnError + (Socket.socket Socket.AF_INET Socket.Stream proto) + (Socket.close) + (\sock -> do + 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.Socket +listenOnIPv4 ip portm = do + hostAddr <- inet_addr ip + E.bracketOnError + (Socket.socket Socket.AF_INET Socket.Stream proto) + (Socket.close) + (\sock -> do + 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' + Socket.setSocketOption lsocket Socket.KeepAlive 1 + listen' lsocket conf hand + +-- | Use a previously bind port and listen +listen' :: Socket.Socket -> Conf -> (Request -> IO Response) -> IO () +listen' s conf hand = do +{- +#ifndef mingw32_HOST_OS +-} + void $ installHandler openEndedPipe Ignore Nothing +{- +#endif +-} + let port' = port conf + fork = case threadGroup conf of + Nothing -> forkIO + Just tg -> \m -> fst `liftM` TG.forkIO tg m + tm <- initialize ((timeout conf) * (10^(6 :: Int))) + -- http:// loop + log' NOTICE ("Listening for http:// on port " ++ show port') + let eh (x::SomeException) = when ((fromException x) /= Just ThreadKilled) $ log' ERROR ("HTTP request failed with: " ++ show x) + work (sock, hn, p) = + do tid <- myThreadId + thandle <- register tm (killThread tid) + let timeoutIO = TS.timeoutSocketIO thandle sock + request timeoutIO (logAccess conf) (hn,fromIntegral p) hand `E.catch` eh + -- remove thread from timeout table + cancel thandle + 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` (Socket.close s >> when (isNothing $ threadGroup conf) (forceTimeoutAll tm)) + +{-- +#ifndef mingw32_HOST_OS +-} + void $ installHandler openEndedPipe Ignore Nothing +{- +#endif +-} + where -- why are these handlers needed? + + catchSome op h = op `E.catches` [ + Handler $ \(e :: ArithException) -> h (toException e), + Handler $ \(e :: ArrayException) -> h (toException e), + Handler $ \(e :: IOException) -> + if isFullError e + then return () -- h (toException e) -- we could log the exception, but there could be thousands of them + else throw e + ] diff --git a/src/Happstack/Server/Internal/LogFormat.hs b/src/Happstack/Server/Internal/LogFormat.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/LogFormat.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE CPP #-} +module Happstack.Server.Internal.LogFormat + ( formatTimeCombined + , formatRequestCombined + ) where + +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 +-- +-- The format is: +-- [day/month/year:hour:minute:second zone] +-- day = 2*digit +-- month = 3*letter +-- year = 4*digit +-- hour = 2*digit +-- minute = 2*digit +-- second = 2*digit +-- zone = (`+' | `-') 4*digit +formatTimeCombined :: FormatTime t => t -> String +formatTimeCombined = formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z" + +-- | Format the request as describe in the Apache combined log format. +-- http://httpd.apache.org/docs/2.2/logs.html#combined +-- +-- The format is: "%h - %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-agent}i\"" +-- %h: This is the IP address of the client (remote host) which made the request to the server. +-- %u: This is the userid of the person requesting the document as determined by HTTP authentication. +-- %t: The time that the request was received. +-- %r: The request line from the client is given in double quotes. +-- %>s: This is the status code that the server sends back to the client. +-- %b: The last part indicates the size of the object returned to the client, not including the response headers. +-- %{Referer}: The "Referer" (sic) HTTP request header. +-- %{User-agent}: The User-Agent HTTP request header. +formatRequestCombined :: FormatTime t => + String + -> String + -> t + -> String + -> Int + -> Integer + -> String + -> String + -> String +formatRequestCombined host user time requestLine responseCode size referer userAgent = + unwords + [ host + , user + , "[" ++ formattedTime ++ "]" + , show requestLine + , show responseCode + , show size + , show referer + , show userAgent + ] + where formattedTime = formatTimeCombined time diff --git a/src/Happstack/Server/Internal/LowLevel.hs b/src/Happstack/Server/Internal/LowLevel.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/LowLevel.hs @@ -0,0 +1,28 @@ +module Happstack.Server.Internal.LowLevel + (-- * HTTP Implementation + -- $impl + + -- * Problems + -- $problems + + -- * API + module Happstack.Server.Internal.Handler, + module Happstack.Server.Internal.Listen, + module Happstack.Server.Internal.Types + ) where + +import Happstack.Server.Internal.Handler +import Happstack.Server.Internal.Listen +import Happstack.Server.Internal.Types + +-- $impl +-- The Happstack HTTP implementation supports HTTP 1.0 and 1.1. +-- Multiple request on a connection including pipelining is supported. + +-- $problems +-- Currently if a client sends an invalid HTTP request the whole +-- connection is aborted and no further processing is done. +-- +-- When the connection times out Happstack closes it. In future it could +-- send a 408 response but this may be problematic if the sending +-- of a response caused the problem. diff --git a/src/Happstack/Server/Internal/MessageWrap.hs b/src/Happstack/Server/Internal/MessageWrap.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/MessageWrap.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Happstack.Server.Internal.MessageWrap ( + module Happstack.Server.Internal.MessageWrap + ,defaultInputIter + ) where + +import Control.Concurrent.MVar (tryTakeMVar, tryPutMVar, putMVar) +import Control.Monad.Trans (MonadIO(liftIO)) +import qualified Data.ByteString.Char8 as P +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.ByteString.UTF8 as U (toString) +import Data.Int (Int64) +import Happstack.Server.Internal.Types as H +import Happstack.Server.Internal.Multipart +import Happstack.Server.Internal.RFC822Headers (parseContentType) +import Happstack.Server.SURI as SURI + +queryInput :: SURI -> [(String, Input)] +queryInput uri = formDecode (case SURI.query uri of + '?':r -> r + xs -> xs) + +-- | see 'defaultBodyPolicy' +data BodyPolicy + = BodyPolicy { inputWorker :: Int64 -> Int64 -> Int64 -> InputWorker + , maxDisk :: Int64 -- ^ maximum bytes for files uploaded in this 'Request' + , maxRAM :: Int64 -- ^ maximum bytes for all non-file values in the 'Request' body + , maxHeader :: Int64 -- ^ maximum bytes of overhead for headers in @multipart/form-data@ + } + +-- | create a 'BodyPolicy' for use with decodeBody +defaultBodyPolicy :: FilePath -- ^ temporary directory for file uploads + -> Int64 -- ^ maximum bytes for files uploaded in this 'Request' + -> Int64 -- ^ maximum bytes for all non-file values in the 'Request' body + -> Int64 -- ^ maximum bytes of overhead for headers in @multipart/form-data@ + -> BodyPolicy +defaultBodyPolicy tmpDir md mr mh = + BodyPolicy { inputWorker = defaultInputIter defaultFileSaver tmpDir 0 0 0 + , maxDisk = md + , maxRAM = mr + , maxHeader = mh + } + +bodyInput :: (MonadIO m) => BodyPolicy -> Request -> m ([(String, Input)], Maybe String) +bodyInput _ req | (not (canHaveBody (rqMethod req))) || (not (isDecodable ctype)) = + do _ <- liftIO $ tryPutMVar (rqInputsBody req) [] + return ([], Nothing) + where + ctype :: Maybe ContentType + ctype = 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 + +bodyInput bodyPolicy req = + liftIO $ + do let ctype = parseContentType . P.unpack =<< getHeader "content-type" req + mbi <- tryTakeMVar (rqInputsBody req) + case mbi of + (Just bi) -> + do putMVar (rqInputsBody req) bi + return (bi, Nothing) + Nothing -> + do rqbody <- takeRequestBody req + case rqbody of + Nothing -> return ([], Just $ "bodyInput: Request body was already consumed.") + (Just (Body bs)) -> + do r@(inputs, _err) <- decodeBody bodyPolicy ctype bs + putMVar (rqInputsBody req) inputs + return r + +-- | Decodes application\/x-www-form-urlencoded inputs. +-- TODO: should any of the [] be error conditions? +formDecode :: String -> [(String, Input)] +formDecode [] = [] +formDecode qString = + if null pairString then rest else + (SURI.unEscapeQS name,simpleInput $ SURI.unEscapeQS val):rest + where (pairString,qString')= split (=='&') qString + (name,val)=split (=='=') pairString + rest=if null qString' then [] else formDecode qString' + +-- | Decodes application\/x-www-form-urlencoded inputs. +-- TODO: should any of the [] be error conditions? +formDecodeBS :: L.ByteString -> [(String, Input)] +formDecodeBS qString | L.null qString = [] +formDecodeBS qString = + if L.null pairString + then rest -- skip in case of consecutive ampersands "...&&..." + else (SURI.unEscapeQS (L.unpack name), simpleInput $ SURI.unEscapeQS (L.unpack $ L.drop 1 val)) : rest + where (pairString,qString') = L.break (== '&') qString + (name,val) = L.break (== '=') pairString + rest = formDecodeBS (L.drop 1 qString') + +-- FIXME: is usend L.unpack really the right thing to do +decodeBody :: BodyPolicy + -> Maybe ContentType + -> L.ByteString + -> IO ([(String,Input)], Maybe String) +decodeBody bp ctype inp + = case ctype of + Just (ContentType "application" "x-www-form-urlencoded" _) -> + return decodedUrlEncodedForm + Just (ContentType "multipart" "form-data" ps) -> + multipartDecode ((inputWorker bp) (maxDisk bp) (maxRAM bp) (maxHeader bp)) ps inp + Just ct -> + return ([], Just $ "decodeBody: unsupported content-type: " ++ show ct) -- unknown content-type, the user will have to + -- deal with it by looking at the raw content + -- No content-type given, assume x-www-form-urlencoded + Nothing -> return decodedUrlEncodedForm + where + (upToMaxRAM,overMaxRAM) = L.splitAt (maxRAM bp) inp + decodedUrlEncodedForm = (formDecodeBS upToMaxRAM, + if L.null overMaxRAM + then Nothing + else Just ("x-www-form-urlencoded content longer than BodyPolicy.maxRAM=" ++ show (maxRAM bp) ++ " bytes")) + +-- | Decodes multipart\/form-data input. +multipartDecode :: InputWorker + -> [(String,String)] -- ^ Content-type parameters + -> L.ByteString -- ^ Request body + -> IO ([(String,Input)], Maybe String) -- ^ Input variables and values. +multipartDecode worker ps inp = + case lookup "boundary" ps of + Just b -> multipartBody worker (L.pack b) inp + Nothing -> return ([], Just $ "boundary not found in parameters: " ++ show ps) + +-- | Get the path components from a String. +pathEls :: String -> [String] +pathEls = (drop 1) . map (U.toString . P.pack . SURI.unEscape) . splitList '/' + +-- | Repeadly splits a list by the provided separator and collects the results +splitList :: Eq a => a -> [a] -> [[a]] +splitList _ [] = [] +splitList sep list = h:splitList sep t + where (h,t)=split (==sep) list + +-- | Repeatedly splits a list and collects the results +splitListBy :: (a -> Bool) -> [a] -> [[a]] +splitListBy _ [] = [] +splitListBy f list = h:splitListBy f t + where (h,t)=split f list + +-- | Split is like break, but the matching element is dropped. +split :: (a -> Bool) -> [a] -> ([a], [a]) +split f s = (left,right) + where + (left,right')=break f s + right = if null right' then [] else tail right' + diff --git a/src/Happstack/Server/Internal/Monads.hs b/src/Happstack/Server/Internal/Monads.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/Monads.hs @@ -0,0 +1,800 @@ +{-# 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.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 ) +import Control.Monad.Trans ( MonadTrans, lift + , MonadIO, liftIO + ) +import Control.Monad.Trans.Control ( MonadTransControl(..) + , MonadBaseControl(..) + , ComposeSt, defaultLiftBaseWith, defaultRestoreM + ) +import Control.Monad.Writer.Class ( MonadWriter, tell, pass, listens ) +import qualified Control.Monad.Writer.Lazy as Lazy ( WriterT(WriterT), runWriterT, mapWriterT ) +import qualified Control.Monad.Writer.Strict as Strict ( WriterT, mapWriterT ) +import qualified Control.Monad.Writer.Class as Writer ( listen ) + +import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT) +import qualified Data.ByteString.Char8 as P +import qualified Data.ByteString.Lazy.UTF8 as LU (fromString) +import Data.Char (ord) +import Data.List (inits, isPrefixOf, stripPrefix, tails) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid(mempty, mappend), Dual(..), Endo(..)) +import qualified Data.Semigroup as SG +import qualified Paths_happstack_server as Cabal +import qualified Data.Version as DV +import Debug.Trace (trace) + +import Happstack.Server.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 + +-- | An alias for @'ServerPartT' 'IO'@ +type ServerPart a = ServerPartT IO a + +-------------------------------------- +-- HERE BEGINS ServerPartT definitions + +-- | 'ServerPartT' is a rich, featureful monad for web development. +-- +-- 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 + +instance (MonadIO m) => MonadIO (ServerPartT m) where + liftIO = ServerPartT . liftIO + {-# INLINE liftIO #-} + +instance MonadTransControl ServerPartT where + type StT ServerPartT a = StT WebT (StT (ReaderT Request) a) + liftWith f = ServerPartT $ liftWith $ \runReader -> + liftWith $ \runWeb -> + f $ runWeb . runReader . unServerPartT + restoreT = ServerPartT . restoreT . restoreT + +instance MonadBaseControl b m => MonadBaseControl b (ServerPartT m) where + 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'. +runServerPartT :: ServerPartT m a -> Request -> WebT m a +runServerPartT = runReaderT . unServerPartT + +-- | function for lifting WebT to ServerPartT +-- +-- NOTE: This is mostly for internal use. If you want to access the +-- 'Request' in user-code see 'askRq' from 'ServerMonad'. +-- +-- > do request <- askRq +-- > ... +withRequest :: (Request -> WebT m a) -> ServerPartT m a +withRequest = ServerPartT . ReaderT + +-- | A constructor for a 'ServerPartT' when you don't care about the request. +-- +-- NOTE: This is mostly for internal use. If you think you need to use +-- it in your own code, you might consider asking on the mailing list +-- or IRC to find out if there is an alternative solution. +anyRequest :: Monad m => WebT m a -> ServerPartT m a +anyRequest x = withRequest $ \_ -> x + +-- | Apply a function to transform the inner monad of +-- @'ServerPartT' m@. +-- +-- Often used when transforming a monad with 'ServerPartT', since +-- 'simpleHTTP' requires a @'ServerPartT' 'IO' a@. Refer to 'UnWebT' +-- for an explanation of the structure of the monad. +-- +-- Here is an example. Suppose you want to embed an 'ErrorT' into your +-- 'ServerPartT' to enable 'throwError' and 'catchError' in your 'Monad'. +-- +-- > type MyServerPartT e m a = ServerPartT (ErrorT e m) a +-- +-- Now suppose you want to pass @MyServerPartT@ into a function that +-- demands a @'ServerPartT' 'IO' a@ (e.g. 'simpleHTTP'). You can +-- provide the function: +-- +-- > unpackErrorT :: (Monad m, Show e) => UnWebT (ErrorT e m) a -> UnWebT m a +-- > unpackErrorT et = do +-- > eitherV <- runErrorT et +-- > return $ case eitherV of +-- > Left err -> Just (Left $ toResponse $ +-- > "Catastrophic failure " ++ show err +-- > , filterFun $ \r -> r{rsCode = 500}) +-- > Right x -> x +-- +-- With @unpackErrorT@ you can now call 'simpleHTTP'. Just wrap your +-- 'ServerPartT' list. +-- +-- > simpleHTTP nullConf $ mapServerPartT unpackErrorT (myPart `catchError` myHandler) +-- +-- Or alternatively: +-- +-- > simpleHTTP' unpackErrorT nullConf (myPart `catchError` myHandler) +-- +-- Also see 'Happstack.Server.Error.spUnwrapErrorT' for a more sophisticated version of this +-- function. +-- +mapServerPartT :: ( UnWebT m a -> UnWebT n b) + -> (ServerPartT m a -> ServerPartT n b) +mapServerPartT f ma = withRequest $ \rq -> mapWebT f (runServerPartT ma rq) + +-- | A variant of 'mapServerPartT' where the first argument also takes +-- a 'Request'. Useful if you want to 'runServerPartT' on a different +-- 'ServerPartT' inside your monad (see 'spUnwrapErrorT'). +mapServerPartT' :: (Request -> UnWebT m a -> UnWebT n b) + -> ( ServerPartT m a -> ServerPartT n b) +mapServerPartT' f ma = withRequest $ \rq -> mapWebT (f rq) (runServerPartT ma rq) + +instance MonadTrans (ServerPartT) where + lift m = withRequest (\_ -> lift m) + +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 = (SG.<>) + +instance (Monad m, Functor m) => Applicative (ServerPartT m) where + pure = return + (<*>) = ap + +instance (Functor m, MonadPlus m) => Alternative (ServerPartT m) where + empty = mzero + (<|>) = mplus + +instance (Monad m, MonadWriter w m) => MonadWriter w (ServerPartT m) where + tell = lift . tell + listen m = withRequest $ \rq -> Writer.listen (runServerPartT m rq) >>= return + pass m = withRequest $ \rq -> pass (runServerPartT m rq) >>= return + +instance (Monad m, MonadError e m) => MonadError e (ServerPartT m) where + throwError e = lift $ throwError e + catchError action handler = withRequest $ \rq -> (runServerPartT action rq) `catchError` ((flip runServerPartT $ rq) . handler) + +instance (Monad m, MonadReader r m) => MonadReader r (ServerPartT m) where + ask = lift ask + local fn m = withRequest $ \rq-> local fn (runServerPartT m rq) + +instance (Monad m, MonadState s m) => MonadState s (ServerPartT m) where + get = lift get + put = lift . put + +instance Monad m => FilterMonad Response (ServerPartT m) where + setFilter = anyRequest . setFilter + composeFilter = anyRequest . composeFilter + getFilter m = withRequest $ \rq -> getFilter (runServerPartT m rq) + +instance Monad m => WebMonad Response (ServerPartT m) where + finishWith r = anyRequest $ finishWith r + +-- | The 'ServerMonad' class provides methods for reading or locally +-- modifying the 'Request'. It is essentially a specialized version of +-- the 'MonadReader' class. Providing the unique names, 'askRq' and +-- 'localRq' makes it easier to use 'ServerPartT' and 'ReaderT' +-- together. +class Monad m => ServerMonad m where + askRq :: m Request + localRq :: (Request -> Request) -> m a -> m a + +instance (Monad m) => ServerMonad (ServerPartT m) where + 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 + +-- | A monoid operation container. If @a@ is a monoid, then +-- 'SetAppend' is a monoid with the following behaviors: +-- +-- > Set x `mappend` Append y = Set (x `mappend` y) +-- > Append x `mappend` Append y = Append (x `mappend` y) +-- > _ `mappend` Set y = Set y +-- +-- A simple way of summarizing this is, if the right side is 'Append', +-- then the right is appended to the left. If the right side is +-- 'Set', then the left side is ignored. + +data SetAppend a = Set a | Append a + deriving (Eq, Show) + +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 + +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: +-- +-- But lets not drag in that dependency. yet... +extract :: SetAppend t -> t +extract (Set x) = x +extract (Append x) = x + +instance Functor (SetAppend) where + fmap f (Set x) = Set $ f x + fmap f (Append x) = Append $ f x + +-- | 'FilterFun' is a lot more fun to type than @'SetAppend' ('Dual' +-- ('Endo' a))@. +type FilterFun a = SetAppend (Dual (Endo a)) + +unFilterFun :: FilterFun a -> (a -> a) +unFilterFun = appEndo . getDual . extract + +-- | turn a function into a 'FilterFun'. Primarily used with 'mapServerPartT' +filterFun :: (a -> a) -> FilterFun a +filterFun = Set . Dual . Endo + +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 + +instance (MonadIO m) => MonadIO (FilterT a m) where + liftIO = FilterT . liftIO + {-# INLINE liftIO #-} + +instance MonadTransControl (FilterT a) where + 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 + type StM (FilterT a m) c = ComposeSt (FilterT a) m c + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + +-- | A set of functions for manipulating filters. +-- +-- 'ServerPartT' implements 'FilterMonad' 'Response' so these methods +-- are the fundamental ways of manipulating 'Response' values. +class Monad m => FilterMonad a m | m->a where + -- | Ignores all previous alterations to your filter + -- + -- As an example: + -- + -- > do + -- > composeFilter f + -- > setFilter g + -- > return "Hello World" + -- + -- The @'setFilter' g@ will cause the first @'composeFilter' f@ to + -- be ignored. + setFilter :: (a->a) -> m () + -- | Composes your filter function with the existing filter + -- function. + composeFilter :: (a->a) -> m () + -- | Retrieves the filter from the environment. + getFilter :: m b -> m (b, a->a) + +-- | Resets all your filters. An alias for @'setFilter' 'id'@. +ignoreFilters :: (FilterMonad a m) => m () +ignoreFilters = setFilter id + +instance (Monad m) => FilterMonad a (FilterT a m) where + setFilter = FilterT . tell . Set . Dual . Endo + composeFilter = FilterT . tell . Append . Dual . Endo + getFilter = FilterT . listens unFilterFun . unFilterT + +-- | The basic 'Response' building object. +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 + +instance (MonadIO m) => MonadIO (WebT m) where + liftIO = WebT . liftIO + {-# INLINE liftIO #-} + +instance MonadTransControl WebT where + type StT WebT a = StT MaybeT + (StT (FilterT Response) + (StT (ExceptT Response) a)) + liftWith f = WebT $ liftWith $ \runError -> + liftWith $ \runFilter -> + liftWith $ \runMaybe -> + f $ runMaybe . + runFilter . + runExceptT . unWebT + restoreT = WebT . restoreT . restoreT . restoreT + +instance MonadBaseControl b m => MonadBaseControl b (WebT m) where + 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 +-- head around this type. If you are -- the type is not as complex as +-- it first appears. +-- +-- It is worth discussing the unpacked structure of 'WebT' a bit as +-- it's exposed in 'mapServerPartT' and 'mapWebT'. +-- +-- A fully unpacked 'WebT' has a structure that looks like: +-- +-- > ununWebT $ WebT m a :: m (Maybe (Either Response a, FilterFun Response)) +-- +-- So, ignoring @m@, as it is just the containing 'Monad', the +-- outermost layer is a 'Maybe'. This is 'Nothing' if 'mzero' was +-- called or @'Just' ('Either' 'Response' a, 'SetAppend' ('Endo' +-- 'Response'))@ if 'mzero' wasn't called. Inside the 'Maybe', there +-- is a pair. The second element of the pair is our filter function +-- @'FilterFun' 'Response'@. @'FilterFun' 'Response'@ is a type +-- alias for @'SetAppend' ('Dual' ('Endo' 'Response'))@. This is +-- just a wrapper for a @'Response' -> 'Response'@ function with a +-- particular 'Monoid' behavior. The value +-- +-- > Append (Dual (Endo f)) +-- +-- Causes @f@ to be composed with the previous filter. +-- +-- > Set (Dual (Endo f)) +-- +-- Causes @f@ to not be composed with the previous filter. +-- +-- Finally, the first element of the pair is either @'Left' +-- 'Response'@ or @'Right' a@. +-- +-- Another way of looking at all these pieces is from the behaviors +-- they control. The 'Maybe' controls the 'mzero' behavior. @'Set' +-- ('Endo' f)@ comes from the 'setFilter' behavior. Likewise, +-- @'Append' ('Endo' f)@ is from 'composeFilter'. @'Left' +-- 'Response'@ is what you get when you call 'finishWith' and +-- @'Right' a@ is the normal exit. +-- +-- An example case statement looks like: +-- +-- > ex1 webt = do +-- > val <- ununWebT webt +-- > case val of +-- > Nothing -> Nothing -- this is the interior value when mzero was used +-- > Just (Left r, f) -> Just (Left r, f) -- r is the value that was passed into "finishWith" +-- > -- f is our filter function +-- > Just (Right a, f) -> Just (Right a, f) -- a is our normal monadic value +-- > -- f is still our filter function +-- +type UnWebT m a = m (Maybe (Either Response a, FilterFun Response)) + +instance Monad m => Monad (WebT m) where + m >>= f = WebT $ unWebT m >>= unWebT . f + {-# INLINE (>>=) #-} + return a = WebT $ return a + {-# INLINE return #-} + +#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 +-- of any type. And unless you call @'setFilter' 'id'@ first your +-- response filters will be applied normally. +-- +-- Extremely useful when you're deep inside a monad and decide +-- that you want to return a completely different content type, +-- since it doesn't force you to convert all your return types to +-- 'Response' early just to accommodate this. +-- +-- see also: 'escape' and 'escape'' +class Monad m => WebMonad a m | m->a where + -- abort the current computation and return a value + finishWith :: a -- ^ value to return (For 'ServerPart', 'a' will always be the type 'Response') + -> m b + +-- | Used to ignore all your filters and immediately end the +-- computation. A combination of 'ignoreFilters' and 'finishWith'. +escape :: (WebMonad a m, FilterMonad a m) => m a -> m b +escape gen = ignoreFilters >> gen >>= finishWith + +-- | An alternate form of 'escape' that can be easily used within a do +-- block. +escape' :: (WebMonad a m, FilterMonad a m) => a -> m b +escape' a = ignoreFilters >> finishWith a + + +instance (Monad m) => WebMonad Response (WebT m) where + finishWith r = WebT $ throwError r + +instance MonadTrans WebT where + lift = WebT . lift . lift . lift + +instance (Monad m, MonadPlus m) => MonadPlus (WebT m) where + -- | Aborts a computation. + -- + -- This is primarily useful because 'msum' will take an array of + -- 'MonadPlus' and return the first one that isn't 'mzero', which + -- is exactly the semantics expected from objects that take lists + -- of 'ServerPartT'. + mzero = WebT $ lift $ lift $ mzero + 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 $ ExceptT $ liftM lft $ getFilter (runExceptT $ unWebT m) + where + lft (Left r, _) = Left r + lft (Right a, f) = Right (a, f) + +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 . runExceptT . unWebT + +-- | For wrapping a 'WebT' back up. @'mkWebT' . 'ununWebT' = 'id'@ +mkWebT :: UnWebT m a -> WebT m a +mkWebT = WebT . ExceptT . FilterT . Lazy.WriterT . MaybeT + +-- | See 'mapServerPartT' for a discussion of this function. +mapWebT :: (UnWebT m a -> UnWebT n b) + -> ( WebT m a -> WebT n b) +mapWebT f ma = mkWebT $ f (ununWebT ma) + +-- | This is kinda like a very oddly shaped 'mapServerPartT' or 'mapWebT'. +-- You probably want one or the other of those. +localContext :: Monad m => (WebT m a -> WebT m' a) -> ServerPartT m a -> ServerPartT m' a +localContext fn hs + = withRequest $ \rq -> fn (runServerPartT hs rq) + +instance (Monad m, Functor m) => Applicative (WebT m) where + pure = return + (<*>) = ap + +instance (Functor m, MonadPlus m) => Alternative (WebT m) where + empty = mzero + (<|>) = mplus + +instance MonadReader r m => MonadReader r (WebT m) where + ask = lift ask + local fn m = mkWebT $ local fn (ununWebT m) + +instance MonadState st m => MonadState st (WebT m) where + get = lift get + put = lift . put + +instance MonadError e m => MonadError e (WebT m) where + throwError err = lift $ throwError err + catchError action handler = mkWebT $ catchError (ununWebT action) (ununWebT . handler) + +instance MonadWriter w m => MonadWriter w (WebT m) where + tell = lift . tell + listen m = mkWebT $ Writer.listen (ununWebT m) >>= (return . liftWebT) + where liftWebT (Nothing, _) = Nothing + liftWebT (Just (Left x,f), _) = Just (Left x,f) + liftWebT (Just (Right x,f),w) = Just (Right (x,w),f) + pass m = mkWebT $ ununWebT m >>= liftWebT + where liftWebT Nothing = return Nothing + liftWebT (Just (Left x,f)) = return $ Just (Left x, f) + liftWebT (Just (Right x,f)) = pass (return x)>>= (\a -> return $ Just (Right a,f)) + +-- | Deprecated: use 'msum'. +multi :: (Monad m, MonadPlus m) => [ServerPartT m a] -> ServerPartT m a +multi = msum +{-# DEPRECATED multi "Use msum instead" #-} + +-- | What is this for, exactly? I don't understand why @Show a@ is +-- even in the context Deprecated: This function appears to do nothing +-- at all. If it use it, let us know why. +debugFilter :: (MonadIO m, Show a) => ServerPartT m a -> ServerPartT m a +debugFilter handle = + withRequest $ \rq -> do + r <- runServerPartT handle rq + return r +{-# DEPRECATED debugFilter "This function appears to do nothing." #-} + + +-- "Pattern match failure in do expression at src\AppControl.hs:43:24" +-- is converted to: +-- "src\AppControl.hs:43:24: Pattern match failure in do expression" +-- Then we output this to stderr. Help debugging under Emacs console when using GHCi. +-- This is GHC specific, but you may add your favourite compiler here also. +outputTraceMessage :: String -> a -> a +outputTraceMessage s c | "Pattern match failure " `isPrefixOf` s = + let w = [(k,p) | (i,p) <- zip (tails s) (inits s), Just k <- [stripPrefix " at " i]] + v = concatMap (\(k,p) -> k ++ ": " ++ p) w + in trace v c +outputTraceMessage s c = trace s c + + +mkFailMessage :: (FilterMonad Response m, WebMonad Response m) => String -> m b +mkFailMessage s = do + ignoreFilters + finishWith (failResponse s) + +failResponse :: String -> Response +failResponse s = + setHeader "Content-Type" "text/html; charset=UTF-8" $ + resultBS 500 (LU.fromString (failHtml s)) + +failHtml:: String->String +failHtml errString = + "" + ++ "Happstack " + ++ ver ++ " Internal Server Error" + ++ "

Happstack " ++ ver ++ "

" + ++ "

Something went wrong here
" + ++ "Internal server error
" + ++ "Everything has stopped

" + ++ "

The error was \"" ++ (escapeString errString) ++ "\"

" + where ver = DV.showVersion Cabal.version + +escapeString :: String -> String +escapeString str = concatMap encodeEntity str + where + encodeEntity :: Char -> String + encodeEntity '<' = "<" + encodeEntity '>' = ">" + encodeEntity '&' = "&" + encodeEntity '"' = """ + encodeEntity c + | ord c > 127 = "&#" ++ show (ord c) ++ ";" + | otherwise = [c] + +------------------------------------------------------------------------------ +-- ServerMonad, FilterMonad, and WebMonad instances for ReaderT, StateT, +-- WriterT, RWST, and ErrorT +------------------------------------------------------------------------------ + +-- ReaderT + +instance (ServerMonad m) => ServerMonad (ReaderT r m) where + askRq = lift askRq + localRq f = mapReaderT (localRq f) + +instance (FilterMonad res m) => FilterMonad res (ReaderT r m) where + setFilter f = lift $ setFilter f + composeFilter = lift . composeFilter + getFilter = mapReaderT getFilter + +instance (WebMonad a m) => WebMonad a (ReaderT r m) where + finishWith = lift . finishWith + +-- StateT + +instance (ServerMonad m) => ServerMonad (Lazy.StateT s m) where + askRq = lift askRq + localRq f = Lazy.mapStateT (localRq f) + +instance (ServerMonad m) => ServerMonad (Strict.StateT s m) where + askRq = lift askRq + localRq f = Strict.mapStateT (localRq f) + +instance (FilterMonad res m) => FilterMonad res (Lazy.StateT s m) where + setFilter f = lift $ setFilter f + composeFilter = lift . composeFilter + getFilter m = Lazy.mapStateT (\m' -> + do ((b,s), f) <- getFilter m' + return ((b, f), s)) m + +instance (FilterMonad res m) => FilterMonad res (Strict.StateT s m) where + setFilter f = lift $ setFilter f + composeFilter = lift . composeFilter + getFilter m = Strict.mapStateT (\m' -> + do ((b,s), f) <- getFilter m' + return ((b, f), s)) m + +instance (WebMonad a m) => WebMonad a (Lazy.StateT s m) where + finishWith = lift . finishWith + +instance (WebMonad a m) => WebMonad a (Strict.StateT s m) where + finishWith = lift . finishWith + +-- WriterT + +instance (ServerMonad m, Monoid w) => ServerMonad (Lazy.WriterT w m) where + askRq = lift askRq + localRq f = Lazy.mapWriterT (localRq f) + +instance (ServerMonad m, Monoid w) => ServerMonad (Strict.WriterT w m) where + askRq = lift askRq + localRq f = Strict.mapWriterT (localRq f) + +instance (FilterMonad res m, Monoid w) => FilterMonad res (Lazy.WriterT w m) where + setFilter f = lift $ setFilter f + composeFilter = lift . composeFilter + getFilter m = Lazy.mapWriterT (\m' -> + do ((b,w), f) <- getFilter m' + return ((b, f), w)) m + +instance (FilterMonad res m, Monoid w) => FilterMonad res (Strict.WriterT w m) where + setFilter f = lift $ setFilter f + composeFilter = lift . composeFilter + getFilter m = Strict.mapWriterT (\m' -> + do ((b,w), f) <- getFilter m' + return ((b, f), w)) m + +instance (WebMonad a m, Monoid w) => WebMonad a (Lazy.WriterT w m) where + finishWith = lift . finishWith + +instance (WebMonad a m, Monoid w) => WebMonad a (Strict.WriterT w m) where + finishWith = lift . finishWith + +-- RWST + +instance (ServerMonad m, Monoid w) => ServerMonad (Lazy.RWST r w s m) where + askRq = lift askRq + localRq f = Lazy.mapRWST (localRq f) + +instance (ServerMonad m, Monoid w) => ServerMonad (Strict.RWST r w s m) where + askRq = lift askRq + localRq f = Strict.mapRWST (localRq f) + +instance (FilterMonad res m, Monoid w) => FilterMonad res (Lazy.RWST r w s m) where + setFilter f = lift $ setFilter f + composeFilter = lift . composeFilter + getFilter m = Lazy.mapRWST (\m' -> + do ((b,s,w), f) <- getFilter m' + return ((b, f), s, w)) m + +instance (FilterMonad res m, Monoid w) => FilterMonad res (Strict.RWST r w s m) where + setFilter f = lift $ setFilter f + composeFilter = lift . composeFilter + getFilter m = Strict.mapRWST (\m' -> + do ((b,s,w), f) <- getFilter m' + return ((b, f), s, w)) m + +instance (WebMonad a m, Monoid w) => WebMonad a (Lazy.RWST r w s m) where + finishWith = lift . finishWith + +instance (WebMonad a m, Monoid w) => WebMonad a (Strict.RWST r w s m) where + finishWith = lift . finishWith + +-- ErrorT + +#if !MIN_VERSION_transformers(0,6,0) +instance (Error e, ServerMonad m) => ServerMonad (ErrorT e m) where + askRq = lift askRq + localRq f = mapErrorT $ localRq f + +instance (Error e, FilterMonad a m) => FilterMonad a (ErrorT e m) where + setFilter f = lift $ setFilter f + composeFilter = lift . composeFilter + getFilter m = mapErrorT (\m' -> + do (eb, f) <- getFilter m' + case eb of + (Left e) -> return (Left e) + (Right b) -> return $ Right (b, f) + ) m + +instance (Error e, WebMonad a m) => WebMonad a (ErrorT e m) where + finishWith = lift . finishWith +#endif + +-- ExceptT + +instance ServerMonad m => ServerMonad (ExceptT e m) where + askRq = lift askRq + localRq f = mapExceptT $ localRq f + +instance (FilterMonad a m) => FilterMonad a (ExceptT e m) where + setFilter f = lift $ setFilter f + composeFilter = lift . composeFilter + getFilter m = mapExceptT (\m' -> + do (eb, f) <- getFilter m' + case eb of + (Left e) -> return (Left e) + (Right b) -> return $ Right (b, f) + ) m + +instance WebMonad a m => WebMonad a (ExceptT e m) where + finishWith = lift . finishWith + +escapeHTTP :: (ServerMonad m, MonadIO m) => + (TimeoutIO -> IO ()) + -> m a +escapeHTTP h = liftIO (throwIO (EscapeHTTP h)) diff --git a/src/Happstack/Server/Internal/Multipart.hs b/src/Happstack/Server/Internal/Multipart.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/Multipart.hs @@ -0,0 +1,281 @@ +module Happstack.Server.Internal.Multipart where + +import Control.Monad (MonadPlus(mplus)) +import Data.ByteString.Base64.Lazy +import qualified Data.ByteString.Lazy.Char8 as L +import Data.ByteString.Lazy.Internal (ByteString(Chunk, Empty)) +import qualified Data.ByteString.Lazy.UTF8 as LU +import qualified Data.ByteString.Char8 as S +import Data.Maybe (fromMaybe) +import Data.Int (Int64) +import Text.ParserCombinators.Parsec (parse) +import Happstack.Server.Internal.Types (Input(..)) +import Happstack.Server.Internal.RFC822Headers +import System.IO (Handle, hClose, openBinaryTempFile) + +-- | similar to the normal 'span' function, except the predicate gets the whole rest of the lazy bytestring, not just one character. +-- +-- TODO: this function has not been profiled. +spanS :: (L.ByteString -> Bool) -> L.ByteString -> (L.ByteString, L.ByteString) +spanS f cs0 = spanS' 0 cs0 + where spanS' _ Empty = (Empty, Empty) + spanS' n bs@(Chunk c cs) + | n >= S.length c = + let (x, y) = spanS' 0 cs + in (Chunk c x, y) + | not (f (Chunk (S.drop n c) cs)) = L.splitAt (fromIntegral n) bs + | otherwise = (spanS' (n + 1) bs) +{-# INLINE spanS #-} + +takeWhileS :: (L.ByteString -> Bool) -> L.ByteString -> L.ByteString +takeWhileS f cs0 = takeWhile' 0 cs0 + where takeWhile' _ Empty = Empty + takeWhile' n bs@(Chunk c cs) + | n >= S.length c = Chunk c (takeWhile' 0 cs) + | not (f (Chunk (S.drop n c) cs)) = (Chunk (S.take n c) Empty) + | otherwise = takeWhile' (n + 1) bs + +crlf :: L.ByteString +crlf = L.pack "\r\n" + +crlfcrlf :: L.ByteString +crlfcrlf = L.pack "\r\n\r\n" + +blankLine :: L.ByteString +blankLine = L.pack "\r\n\r\n" + +dropWhileS :: (L.ByteString -> Bool) -> L.ByteString -> L.ByteString +dropWhileS f cs0 = dropWhile' cs0 + where dropWhile' bs + | L.null bs = bs + | f bs = dropWhile' (L.drop 1 bs) + | otherwise = bs + +data BodyPart = BodyPart L.ByteString L.ByteString -- ^ headers body + deriving (Eq, Ord, Read, Show) + +data Work + = BodyWork ContentType [(String, String)] L.ByteString + | HeaderWork L.ByteString + +type InputWorker = Work -> IO InputIter + +data InputIter + = Failed (Maybe (String, Input)) String + | BodyResult (String, Input) InputWorker + | HeaderResult [Header] InputWorker + +type FileSaver = FilePath -- ^ tempdir + -> Int64 -- ^ quota + -> FilePath -- ^ filename of field + -> L.ByteString -- ^ content to save + -> IO (Bool, Int64 , FilePath) -- ^ truncated?, saved bytes, saved filename + +defaultFileSaver :: FilePath -> Int64 -> FilePath -> ByteString -> IO (Bool, Int64, FilePath) +defaultFileSaver tmpDir diskQuota filename b + | 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) + | diskCount > maxDisk = return $ Failed Nothing ("diskCount (" ++ show diskCount ++ ") is greater than maxDisk (" ++ show maxDisk ++ ")") + | ramCount > maxRAM = return $ Failed Nothing ("ramCount (" ++ show ramCount ++ ") is greater than maxRAM (" ++ show maxRAM ++ ")") + | otherwise = + case lookup "filename" ps of + Nothing -> + let (b',rest) = L.splitAt (maxRAM - ramCount) b + input = (fromMaybe "" $ lookup "name" ps + , Input { inputValue = (Right b') + , inputFilename = Nothing + , inputContentType = ctype }) + in if L.null rest + then return $ BodyResult input (defaultInputIter fileSaver tmpDir diskCount (ramCount + L.length b) headerCount maxDisk maxRAM maxHeader) + else return $ Failed (Just input) ("Reached RAM quota of " ++ show maxRAM ++ " bytes.") + + (Just filename) -> + do (trunc, len, fn) <- fileSaver tmpDir (maxDisk - diskCount) filename b + let input = ( fromMaybe "" $ lookup "name" ps + , Input { inputValue = Left fn + , inputFilename = (Just filename) + , inputContentType = ctype }) + if trunc + then return $ Failed (Just input) ("Reached disk quota of " ++ show maxDisk ++ " bytes.") + else return $ BodyResult input (defaultInputIter fileSaver tmpDir (diskCount + len) ramCount headerCount maxDisk maxRAM maxHeader) + +defaultInputIter fileSaver tmpDir diskCount ramCount headerCount maxDisk maxRAM maxHeader (HeaderWork bs) = + case L.splitAt (maxHeader - headerCount) bs of + (_hs, rest) + | not (L.null rest) -> return $ Failed Nothing ("Reached header quota of " ++ show maxHeader ++ " bytes.") + | otherwise -> + case parse pHeaders (LU.toString bs) (LU.toString bs) of + (Left e) -> return $ Failed Nothing (show e) + (Right hs) -> + return $ HeaderResult hs + (defaultInputIter fileSaver tmpDir diskCount ramCount (headerCount + (L.length bs)) maxDisk maxRAM maxHeader) +{-# INLINE defaultInputIter #-} + +hPutLimit :: Int64 -> Handle -> L.ByteString -> IO (Bool, Int64) +hPutLimit maxCount h bs = hPutLimit' maxCount h 0 bs +{-# INLINE hPutLimit #-} + +hPutLimit' :: Int64 -> Handle -> Int64 -> L.ByteString -> IO (Bool, Int64) +hPutLimit' _maxCount _h count Empty = return (False, count) +hPutLimit' maxCount h count (Chunk c cs) + | (count + fromIntegral (S.length c)) > maxCount = + do S.hPut h (S.take (fromIntegral (maxCount - count)) c) + return (True, maxCount) + | otherwise = + do S.hPut h c + hPutLimit' maxCount h (count + fromIntegral (S.length c)) cs +{-# INLINE hPutLimit' #-} + +-- FIXME: can we safely use L.unpack, or do we need to worry about encoding issues in the headers? +bodyPartToInput :: InputWorker -> BodyPart -> IO InputIter -- (Either String (String,Input)) +bodyPartToInput inputWorker (BodyPart rawHS b) = + do r <- inputWorker (HeaderWork rawHS) + case r of + (Failed i e) -> return $ Failed i e + (HeaderResult hs cont) -> + let ctype = fromMaybe defaultInputType (getContentType hs) in + case getContentDisposition hs of + Just (ContentDisposition "form-data" ps) -> do + let eb' = case getContentTransferEncoding hs of + Nothing -> Right b + Just (ContentTransferEncoding "7bit") -> + -- We don't bother checking that the data + -- really is 7bit-only + Right b + Just (ContentTransferEncoding "8bit") -> + Right b + Just (ContentTransferEncoding "binary") -> + Right b + Just (ContentTransferEncoding "base64") -> + Right $ decodeLenient b + -- TODO: Support quoted-printable + Just cte -> + Left ("Bad content-transfer-encoding: " ++ show cte) + case eb' of + Right b' -> + cont (BodyWork ctype ps b') + Left err -> + return $ Failed Nothing err + cd -> return $ Failed Nothing ("Expected content-disposition: form-data but got " ++ show cd) + (BodyResult {}) -> return $ Failed Nothing "bodyPartToInput: Got unexpected BodyResult." + +bodyPartsToInputs :: InputWorker -> [BodyPart] -> IO ([(String,Input)], Maybe String) +bodyPartsToInputs _ [] = + return ([], Nothing) +bodyPartsToInputs inputWorker (b:bs) = + do r <- bodyPartToInput inputWorker b + case r of + (Failed mInput e) -> + case mInput of + Nothing -> return ([], Just e) + (Just i) -> return ([i], Just e) + (BodyResult i cont) -> + do (is, err) <- bodyPartsToInputs cont bs + return (i:is, err) + (HeaderResult _ _) -> + return ([], Just "InputWorker is broken. Returned a HeaderResult when a BodyResult was required.") + +multipartBody :: InputWorker -> L.ByteString -> L.ByteString -> IO ([(String, Input)], Maybe String) +multipartBody inputWorker boundary s = + do let (bodyParts, mErr) = parseMultipartBody boundary s + (inputs, mErr2) <- bodyPartsToInputs inputWorker bodyParts + return (inputs, mErr2 `mplus` mErr) + +-- | Packs a string into an Input of type "text/plain" +simpleInput :: String -> Input +simpleInput v + = Input { inputValue = Right (L.pack v) + , inputFilename = Nothing + , inputContentType = defaultInputType + } + +-- | The default content-type for variables. +defaultInputType :: ContentType +defaultInputType = ContentType "text" "plain" [] -- FIXME: use some default encoding? + +parseMultipartBody :: L.ByteString -> L.ByteString -> ([BodyPart], Maybe String) +parseMultipartBody boundary s = + case dropPreamble boundary s of + (_partData, Just e) -> ([], Just e) + (partData, Nothing) -> splitParts boundary partData + +dropPreamble :: L.ByteString -> L.ByteString -> (L.ByteString, Maybe String) +dropPreamble b s | isBoundary b s = (dropLine s, Nothing) + | L.null s = (s, Just $ "Boundary " ++ L.unpack b ++ " not found.") + | otherwise = dropPreamble b (dropLine s) + +dropLine :: L.ByteString -> L.ByteString +dropLine = L.drop 2 . dropWhileS (not . L.isPrefixOf crlf) + +-- | Check whether a string starts with two dashes followed by +-- the given boundary string. +isBoundary :: L.ByteString -- ^ The boundary, without the initial dashes + -> L.ByteString + -> Bool +isBoundary b s = startsWithDashes s && b `L.isPrefixOf` L.drop 2 s + +-- | Checks whether a string starts with two dashes. +startsWithDashes :: L.ByteString -> Bool +startsWithDashes s = L.pack "--" `L.isPrefixOf` s + +splitParts :: L.ByteString -> L.ByteString -> ([BodyPart], Maybe String) +splitParts boundary s = +-- | not (isBoundary boundary s) = ([], Just $ "Missing boundary: " ++ L.unpack boundary ++ "\n" ++ L.unpack s) + case L.null s of + True -> ([], Nothing) + False -> + case splitPart boundary s of + (p, s') -> + let (ps,e) = splitParts boundary s' + in (p:ps, e) +{-# INLINE splitParts #-} + +splitPart :: L.ByteString -> L.ByteString -> (BodyPart, L.ByteString) +splitPart boundary s = + case splitBlank s of + (headers, rest) -> + case splitBoundary boundary (L.drop 4 rest) of + (body, rest') -> (BodyPart (L.append headers crlf) body, rest') +{-# INLINE splitPart #-} + + +splitBlank :: L.ByteString -> (L.ByteString, L.ByteString) +splitBlank s = spanS (not . L.isPrefixOf crlfcrlf) s +{-# INLINE splitBlank #-} + + +splitBoundary :: L.ByteString -> L.ByteString -> (L.ByteString, L.ByteString) +splitBoundary boundary s = + case spanS (not . L.isPrefixOf (L.pack "\r\n--" `L.append` boundary)) s of + (x,y) | (L.pack "\r\n--" `L.append` boundary `L.append` (L.pack "--")) + `L.isPrefixOf` y -> (x, L.empty) + | otherwise -> (x, dropLine (L.drop 2 y)) +{-# INLINE splitBoundary #-} + +splitAtEmptyLine :: L.ByteString -> Maybe (L.ByteString, L.ByteString) +splitAtEmptyLine s = + case splitBlank s of + (before, after) | L.null after -> Nothing + | otherwise -> Just (L.append before crlf, L.drop 4 after) +{-# INLINE splitAtEmptyLine #-} + +-- | Split a string at the first CRLF. The CRLF is not included +-- in any of the returned strings. +splitAtCRLF :: ByteString -- ^ String to split. + -> Maybe (ByteString,ByteString) + -- ^ Returns 'Nothing' if there is no CRLF. +splitAtCRLF s = + case spanS (not . L.isPrefixOf crlf) s of + (before, after) | L.null after -> Nothing + | otherwise -> Just (before, L.drop 2 after) +{-# INLINE splitAtCRLF #-} diff --git a/src/Happstack/Server/Internal/RFC822Headers.hs b/src/Happstack/Server/Internal/RFC822Headers.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/RFC822Headers.hs @@ -0,0 +1,272 @@ +-- #hide + +----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI.RFC822Headers +-- Copyright : (c) Peter Thiemann 2001,2002 +-- (c) Bjorn Bringert 2005-2006 +-- (c) Lemmih 2007 +-- License : BSD-style +-- +-- Maintainer : lemmih@vo.com +-- Stability : experimental +-- Portability : portable +-- +-- Parsing of RFC822-style headers (name, value pairs) +-- Partly based on code from WASHMail. +-- +----------------------------------------------------------------------------- +module Happstack.Server.Internal.RFC822Headers + ( -- * Headers + Header, + pHeader, + pHeaders, + parseHeaders, + + -- * Content-type + ContentType(..), + getContentType, + parseContentType, + showContentType, + + -- * Content-transfer-encoding + ContentTransferEncoding(..), + getContentTransferEncoding, + parseContentTransferEncoding, + + -- * Content-disposition + ContentDisposition(..), + getContentDisposition, + parseContentDisposition, + + -- * Utilities + parseM + ) where + +import Control.Monad +import Control.Monad.Fail (MonadFail) +import Data.Char +import Data.List +import Text.ParserCombinators.Parsec + +type Header = (String, String) + +pHeaders :: Parser [Header] +pHeaders = many pHeader + +parseHeaders :: MonadFail m => SourceName -> String -> m [Header] +parseHeaders = parseM pHeaders + +pHeader :: Parser Header +pHeader = + do name <- many1 headerNameChar + void $ char ':' + void $ many ws1 + line <- lineString + void crLf + extraLines <- many extraFieldLine + return (map toLower name, concat (line:extraLines)) + +extraFieldLine :: Parser String +extraFieldLine = + do sp <- ws1 + line <- lineString + void $ crLf + return (sp:line) + +-- +-- * Parameters (for Content-type etc.) +-- + +showParameters :: [(String,String)] -> String +showParameters = concatMap f + where f (n,v) = "; " ++ n ++ "=\"" ++ concatMap esc v ++ "\"" + esc '\\' = "\\\\" + esc '"' = "\\\"" + esc c | c `elem` ['\\','"'] = '\\':[c] + | otherwise = [c] + +p_parameter :: Parser (String,String) +p_parameter = + do void $ lexeme $ char ';' + p_name <- lexeme $ p_token + void $ lexeme $ char '=' + -- Workaround for seemingly standardized web browser bug + -- where nothing is escaped in the filename parameter + -- of the content-disposition header in multipart/form-data + let litStr = if p_name == "filename" + 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) + + +-- +-- * Content type +-- + +-- | A MIME media type value. +-- The 'Show' instance is derived automatically. +-- Use 'showContentType' to obtain the standard +-- string representation. +-- See for more +-- information about MIME media types. +data ContentType = + ContentType { + -- | The top-level media type, the general type + -- of the data. Common examples are + -- \"text\", \"image\", \"audio\", \"video\", + -- \"multipart\", and \"application\". + ctType :: String, + -- | The media subtype, the specific data format. + -- Examples include \"plain\", \"html\", + -- \"jpeg\", \"form-data\", etc. + ctSubtype :: String, + -- | Media type parameters. On common example is + -- the charset parameter for the \"text\" + -- top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@. + ctParameters :: [(String, String)] + } + deriving (Show, Read, Eq, Ord) + +-- | Produce the standard string representation of a content-type, +-- e.g. \"text\/html; charset=ISO-8859-1\". +showContentType :: ContentType -> String +showContentType (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps + +pContentType :: Parser ContentType +pContentType = + do void $ many ws1 + c_type <- p_token + void $ lexeme $ char '/' + c_subtype <- lexeme $ p_token + c_parameters <- many p_parameter + return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters + +-- | 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 :: MonadFail m => String -> m ContentType +parseContentType = parseM pContentType "Content-type" + +getContentType :: MonadFail m => [Header] -> m ContentType +getContentType hs = lookupM "content-type" hs >>= parseContentType + +-- +-- * Content transfer encoding +-- + +data ContentTransferEncoding = + ContentTransferEncoding String + deriving (Show, Read, Eq, Ord) + +pContentTransferEncoding :: Parser ContentTransferEncoding +pContentTransferEncoding = + do void $ many ws1 + c_cte <- p_token + return $ ContentTransferEncoding (map toLower c_cte) + +parseContentTransferEncoding :: MonadFail m => String -> m ContentTransferEncoding +parseContentTransferEncoding = + parseM pContentTransferEncoding "Content-transfer-encoding" + +getContentTransferEncoding :: MonadFail m => [Header] -> m ContentTransferEncoding +getContentTransferEncoding hs = + lookupM "content-transfer-encoding" hs >>= parseContentTransferEncoding + +-- +-- * Content disposition +-- + +data ContentDisposition = + ContentDisposition String [(String, String)] + deriving (Show, Read, Eq, Ord) + +pContentDisposition :: Parser ContentDisposition +pContentDisposition = + do void $ many ws1 + c_cd <- p_token + c_parameters <- many p_parameter + return $ ContentDisposition (map toLower c_cd) c_parameters + +parseContentDisposition :: MonadFail m => String -> m ContentDisposition +parseContentDisposition = parseM pContentDisposition "Content-disposition" + +getContentDisposition :: MonadFail m => [Header] -> m ContentDisposition +getContentDisposition hs = + lookupM "content-disposition" hs >>= parseContentDisposition + +-- +-- * Utilities +-- + +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 :: (MonadFail m, Eq a, Show a) => a -> [(a,b)] -> m b +lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n + +-- +-- * Parsing utilities +-- + +-- | RFC 822 LWSP-char +ws1 :: Parser Char +ws1 = oneOf " \t" + +lexeme :: Parser a -> Parser a +lexeme p = do x <- p; void $ many ws1; return x + +-- | RFC 822 CRLF (but more permissive) +crLf :: Parser String +crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r" + +-- | One line +lineString :: Parser String +lineString = many (noneOf "\n\r") + +literalString :: Parser String +literalString = do void $ char '\"' + str <- many (noneOf "\"\\" <|> quoted_pair) + void $ char '\"' + return str + +-- No web browsers seem to implement RFC 2046 correctly, +-- since they do not escape double quotes and backslashes +-- in the filename parameter in multipart/form-data. +-- +-- Note that this eats everything until the last double quote on the line. +buggyLiteralString :: Parser String +buggyLiteralString = + do void $ char '\"' + str <- manyTill anyChar (try lastQuote) + return str + where lastQuote = do void $ char '\"' + notFollowedBy (try (many (noneOf "\"") >> char '\"')) + +headerNameChar :: Parser Char +headerNameChar = noneOf "\n\r:" + +tspecials, tokenchar :: [Char] +tspecials = "()<>@,;:\\\"/[]?=" -- RFC2045 +tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ tspecials + +p_token :: Parser String +p_token = many1 (oneOf tokenchar) + +text_chars :: [Char] +text_chars = map chr ([1..9] ++ [11,12] ++ [14..127]) + +p_text :: Parser Char +p_text = oneOf text_chars + +quoted_pair :: Parser Char +quoted_pair = do void $ char '\\' + p_text diff --git a/src/Happstack/Server/Internal/Socket.hs b/src/Happstack/Server/Internal/Socket.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/Socket.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP #-} +module Happstack.Server.Internal.Socket + ( acceptLite + , sockAddrToPeer + ) where + +import Data.List (intersperse) +import Data.Word (Word32) +import qualified Network.Socket as S + ( Socket + , PortNumber() + , SockAddr(..) + , HostName + , accept + ) +import Numeric (showHex) + +type HostAddress = Word32 +type HostAddress6 = (Word32, Word32, Word32, Word32) + +-- | Converts a HostAddress to a String in dot-decimal notation +showHostAddress :: HostAddress -> String +showHostAddress num = concat [show q1, ".", show q2, ".", show q3, ".", show q4] + where (num',q1) = num `quotRem` 256 + (num'',q2) = num' `quotRem` 256 + (num''',q3) = num'' `quotRem` 256 + (_,q4) = num''' `quotRem` 256 + +-- | Converts a IPv6 HostAddress6 to standard hex notation +showHostAddress6 :: HostAddress6 -> String +showHostAddress6 (a,b,c,d) = + (concat . intersperse ":" . map (flip showHex "")) + [p1,p2,p3,p4,p5,p6,p7,p8] + where (a',p2) = a `quotRem` 65536 + (_,p1) = a' `quotRem` 65536 + (b',p4) = b `quotRem` 65536 + (_,p3) = b' `quotRem` 65536 + (c',p6) = c `quotRem` 65536 + (_,p5) = c' `quotRem` 65536 + (d',p8) = d `quotRem` 65536 + (_,p7) = d' `quotRem` 65536 + +-- | alternative implementation of accept to work around EAI_AGAIN errors +acceptLite :: S.Socket -> IO (S.Socket, S.HostName, S.PortNumber) +acceptLite sock = do + (sock', addr) <- S.accept sock + let (peer, port) = sockAddrToPeer addr + return (sock', peer, port) + +sockAddrToPeer :: S.SockAddr -> (S.HostName, S.PortNumber) +sockAddrToPeer addr = + case addr of + (S.SockAddrInet p ha) -> (showHostAddress ha, p) + (S.SockAddrInet6 p _ ha _) -> (showHostAddress6 ha, p) + _ -> error "sockAddrToPeer: Unsupported socket type" diff --git a/src/Happstack/Server/Internal/TimeoutIO.hs b/src/Happstack/Server/Internal/TimeoutIO.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/TimeoutIO.hs @@ -0,0 +1,23 @@ +module Happstack.Server.Internal.TimeoutIO + ( TimeoutIO(..) + ) where + +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as L +import Happstack.Server.Internal.TimeoutManager (Handle) +import Network.Socket.SendFile (ByteCount, Offset) + + +-- |TimeoutIO is a record which abstracts out all the network IO +-- functions needed by the request handling loop. This allows use to +-- use the same event loop for handle both http:// and https://. +data TimeoutIO = TimeoutIO + { toHandle :: Handle + , toPutLazy :: L.ByteString -> IO () + , toPut :: B.ByteString -> IO () + , toGet :: IO (Maybe B.ByteString) + , toGetContents :: IO L.ByteString + , toSendFile :: FilePath -> Offset -> ByteCount -> IO () + , toShutdown :: IO () + , toSecure :: Bool + } diff --git a/src/Happstack/Server/Internal/TimeoutManager.hs b/src/Happstack/Server/Internal/TimeoutManager.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/TimeoutManager.hs @@ -0,0 +1,84 @@ +module Happstack.Server.Internal.TimeoutManager + ( Manager + , Handle + , initialize + , register + , registerKillThread + , tickle + , pause + , resume + , cancel + , forceTimeout + , forceTimeoutAll + ) where + +import qualified Data.IORef as I +import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread) +import Control.Monad (forever) +import qualified Control.Exception as E + +-- FIXME implement stopManager + +-- | A timeout manager +newtype Manager = Manager (I.IORef [Handle]) +data Handle = Handle (I.IORef (IO ())) (I.IORef State) +data State = Active | Inactive | Paused | Canceled + +initialize :: Int -> IO Manager +initialize timeout = do + ref <- I.newIORef [] + _ <- forkIO $ forever $ do + threadDelay timeout + ms <- I.atomicModifyIORef ref (\x -> ([], x)) + ms' <- go ms id + I.atomicModifyIORef ref (\x -> (ms' x, ())) + return $ Manager ref + where + go [] front = return front + go (m@(Handle onTimeout iactive):rest) front = do + state <- I.atomicModifyIORef iactive (\x -> (go' x, x)) + case state of + Inactive -> do + action <- I.readIORef onTimeout + action `E.catch` ignoreAll + go rest front + Canceled -> go rest front + _ -> go rest (front . (:) m) + go' Active = Inactive + go' x = x + +ignoreAll :: E.SomeException -> IO () +ignoreAll _ = return () + +register :: Manager -> IO () -> IO Handle +register (Manager ref) onTimeout = do + iactive <- I.newIORef Active + action <- I.newIORef onTimeout + let h = Handle action iactive + I.atomicModifyIORef ref (\x -> (h : x, ())) + return h + +registerKillThread :: Manager -> IO Handle +registerKillThread m = do + tid <- myThreadId + register m $ killThread tid + +tickle, pause, resume, cancel :: Handle -> IO () +tickle (Handle _ iactive) = I.writeIORef iactive $! Active +pause (Handle _ iactive) = I.writeIORef iactive $! Paused +resume = tickle +cancel (Handle action iactive) = + do I.writeIORef iactive $! Canceled + I.writeIORef action $! (return ()) + +forceTimeout :: Handle -> IO () +forceTimeout (Handle action iactive) = + do I.writeIORef iactive $! Canceled + io <- I.atomicModifyIORef action (\io -> (return (), io)) + io `E.catch` ignoreAll + +-- | terminate all threads immediately +forceTimeoutAll :: Manager -> IO () +forceTimeoutAll (Manager ref) = + do hs <- I.atomicModifyIORef ref (\hs -> ([], hs)) + mapM_ forceTimeout hs diff --git a/src/Happstack/Server/Internal/TimeoutSocket.hs b/src/Happstack/Server/Internal/TimeoutSocket.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/TimeoutSocket.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +{- | +-- borrowed from snap-server. Check there periodically for updates. +-} +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) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.ByteString.Lazy.Internal as L +import qualified Data.ByteString as S +import Network.Socket (close) +import qualified Network.Socket.ByteString as N +import qualified Happstack.Server.Internal.TimeoutManager as TM +import Happstack.Server.Internal.TimeoutIO (TimeoutIO(..)) +import Network.Socket (Socket, ShutdownCmd(..), shutdown) +import Network.Socket.SendFile (Iter(..), ByteCount, Offset, sendFileIterWith') +import Network.Socket.ByteString (sendAll) +import System.IO.Error (isDoesNotExistError, ioeGetErrorType) +import System.IO.Unsafe (unsafeInterleaveIO) +import GHC.IO.Exception (IOErrorType(InvalidArgument)) + +sPutLazyTickle :: TM.Handle -> Socket -> L.ByteString -> IO () +sPutLazyTickle thandle sock cs = + do L.foldrChunks (\c rest -> sendAll sock c >> TM.tickle thandle >> rest) (return ()) cs +{-# INLINE sPutLazyTickle #-} + +sPutTickle :: TM.Handle -> Socket -> B.ByteString -> IO () +sPutTickle thandle sock cs = + do sendAll sock cs + TM.tickle thandle + return () +{-# INLINE sPutTickle #-} + +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 +sGetContents handle sock = loop where + loop = unsafeInterleaveIO $ do + s <- N.recv sock 65536 + TM.tickle handle + if S.null s + then do + -- 'InvalidArgument' is GHCs code for eNOTCONN (among other + -- things). Sometimes the other end of socket is closed first + -- and this end is already disconnected before we do + -- 'shutdown'. Ignore this exception. + shutdown sock ShutdownReceive `E.catch` + (\e -> when (not (isDoesNotExistError e || ioeGetErrorType e == InvalidArgument)) (throw e)) + return L.Empty + else L.Chunk s `liftM` loop + + +sendFileTickle :: TM.Handle -> Socket -> FilePath -> Offset -> ByteCount -> IO () +sendFileTickle thandle outs fp offset count = + sendFileIterWith' (iterTickle thandle) outs fp 65536 offset count + +iterTickle :: TM.Handle -> IO Iter -> IO () +iterTickle thandle = + iterTickle' + where + iterTickle' :: (IO Iter -> IO ()) + iterTickle' iter = + do r <- iter + TM.tickle thandle + case r of + (Done _) -> + return () + (WouldBlock _ fd cont) -> + do threadWaitWrite fd + iterTickle' cont + (Sent _ cont) -> + do iterTickle' cont + +timeoutSocketIO :: TM.Handle -> Socket -> TimeoutIO +timeoutSocketIO handle socket = + TimeoutIO { toHandle = handle + , toShutdown = close socket + , toPutLazy = sPutLazyTickle handle socket + , toGet = sGet handle socket + , toPut = sPutTickle handle socket + , toGetContents = sGetContents handle socket + , toSendFile = sendFileTickle handle socket + , toSecure = False + } diff --git a/src/Happstack/Server/Internal/Types.hs b/src/Happstack/Server/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/Types.hs @@ -0,0 +1,536 @@ +{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, RankNTypes, CPP #-} + +module Happstack.Server.Internal.Types + (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..), + takeRequestBody, readInputsBody, + rqURL, mkHeaders, + getHeader, getHeaderBS, getHeaderUnsafe, + hasHeader, hasHeaderBS, hasHeaderUnsafe, + setHeader, setHeaderBS, setHeaderUnsafe, + addHeader, addHeaderBS, addHeaderUnsafe, + setRsCode, -- setCookie, setCookies, + LogAccess, logMAccess, Conf(..), nullConf, result, resultBS, + redirect, -- redirect_, redirect', redirect'_, + isHTTP1_0, isHTTP1_1, + RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength, + HttpVersion(..), Length(..), Method(..), canHaveBody, Headers, continueHTTP, + Host, ContentType(..), + readDec', fromReadS, readM, FromReqURI(..), + showRsValidator, EscapeHTTP(..) + ) where + + +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 +import qualified Data.Map as M +import Data.Data (Data) +import Data.String (fromString) +import Data.Time.Format (FormatTime(..)) +import qualified Data.ByteString.Char8 as P +import Data.ByteString.Char8 (ByteString,pack) +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.ByteString.Lazy.UTF8 as LU (fromString) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Maybe +import Data.List +import Data.Word (Word, Word8, Word16, Word32, Word64) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Lazy +import Happstack.Server.SURI +import Data.Char (toLower) +import Happstack.Server.Internal.RFC822Headers ( ContentType(..) ) +import Happstack.Server.Internal.Cookie +import Happstack.Server.Internal.LogFormat (formatRequestCombined) +import Happstack.Server.Internal.TimeoutIO (TimeoutIO) +import Numeric (readDec, readSigned) +import System.Log.Logger (Priority(..), logM) + +-- | HTTP version +data HttpVersion = HttpVersion Int Int + deriving(Read,Eq) + +instance Show HttpVersion where + show (HttpVersion x y) = (show x) ++ "." ++ (show y) + +-- | 'True' if 'Request' is HTTP version @1.1@ +isHTTP1_1 :: Request -> Bool +isHTTP1_1 rq = + case rqVersion rq of + HttpVersion 1 1 -> True + _ -> False + +-- | 'True' if 'Request' is HTTP version @1.0@ +isHTTP1_0 :: Request -> Bool +isHTTP1_0 rq = + case rqVersion rq of + HttpVersion 1 0 -> True + _ -> False + +-- | Should the connection be used for further messages after this. +-- isHTTP1_0 && hasKeepAlive || isHTTP1_1 && hasNotConnectionClose +-- +-- In addition to this rule All 1xx (informational), 204 (no content), +-- and 304 (not modified) responses MUST NOT include a message-body +-- and therefore are eligible for connection keep-alive. +continueHTTP :: Request -> Response -> Bool +continueHTTP rq rs = + (isHTTP1_0 rq && checkHeaderBS connectionC keepaliveC rq && + (rsfLength (rsFlags rs) == ContentLength || isNoMessageBodyResponse rs)) || + (isHTTP1_1 rq && not (checkHeaderBS connectionC closeC rq) && + (rsfLength (rsFlags rs) /= NoContentLength || isNoMessageBodyResponse rs)) + where + isNoMessageBodyCode code = (code >= 100 && code <= 199) || code == 204 || code == 304 + isNoMessageBodyResponse rs' = isNoMessageBodyCode (rsCode rs') && L.null (rsBody rs') + +-- | function to log access requests (see also: 'logMAccess') +-- type LogAccess time = +-- ( String -- ^ host +-- -> String -- ^ user +-- -> time -- ^ time +-- -> String -- ^ requestLine +-- -> Int -- ^ responseCode +-- -> Integer -- ^ size +-- -> String -- ^ referer +-- -> String -- ^ userAgent +-- -> IO ()) +type LogAccess time = + ( String + -> String + -> time + -> String + -> Int + -> Integer + -> String + -> String + -> IO ()) + +-- | HTTP configuration +data Conf = Conf + { port :: Int -- ^ Port for the server to listen on. + , validator :: Maybe (Response -> IO Response) -- ^ a function to validate the output on-the-fly + , logAccess :: forall t. FormatTime t => Maybe (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. + } + +-- | Default configuration contains no validator and the port is set to 8000 +nullConf :: Conf +nullConf = + Conf { port = 8000 + , validator = Nothing + , logAccess = Just logMAccess + , timeout = 30 + , threadGroup = Nothing + } + +-- | log access requests using hslogger and apache-style log formatting +-- +-- see also: 'Conf' +logMAccess :: forall t. FormatTime t => LogAccess t +logMAccess host user time requestLine responseCode size referer userAgent = + logM "Happstack.Server.AccessLog.Combined" INFO $ formatRequestCombined host user time requestLine responseCode size referer userAgent + +-- | HTTP request method +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 + , hValue :: [ByteString] -- ^ header value (or values if multiple occurances of the header are present) + } + deriving (Read,Show) + +-- | a Map of HTTP headers +-- +-- the Map key is the header converted to lowercase +type Headers = M.Map ByteString HeaderPair -- ^ lowercased name -> (realname, value) + +-- | A flag value set in the 'Response' which controls how the +-- @Content-Length@ header is set, and whether *chunked* output +-- encoding is used. +-- +-- see also: 'nullRsFlags', 'notContentLength', and 'chunked' +data Length + = ContentLength -- ^ automatically add a @Content-Length@ header to the 'Response' + | TransferEncodingChunked -- ^ do not add a @Content-Length@ header. Do use @chunked@ output encoding + | NoContentLength -- ^ do not set @Content-Length@ or @chunked@ output encoding. + deriving (Eq, Ord, Read, Show, Enum) + +-- | Result flags +data RsFlags = RsFlags + { rsfLength :: Length + } deriving (Show, Read) + +-- | Default RsFlags: automatically use @Transfer-Encoding: Chunked@. +nullRsFlags :: RsFlags +nullRsFlags = RsFlags { rsfLength = TransferEncodingChunked } + +-- | Do not automatically add a Content-Length field to the 'Response' +noContentLength :: Response -> Response +noContentLength res = res { rsFlags = flags } where flags = (rsFlags res) { rsfLength = NoContentLength } + +-- | Do not automatically add a Content-Length header. Do automatically use Transfer-Encoding: Chunked +chunked :: Response -> Response +chunked res = res { rsFlags = flags } where flags = (rsFlags res) { rsfLength = TransferEncodingChunked } + +-- | Automatically add a Content-Length header. Do not use Transfer-Encoding: Chunked +contentLength :: Response -> Response +contentLength res = res { rsFlags = flags } where flags = (rsFlags res) { rsfLength = ContentLength } + +-- | a value extract from the @QUERY_STRING@ or 'Request' body +-- +-- If the input value was a file, then it will be saved to a temporary file on disk and 'inputValue' will contain @Left pathToTempFile@. +data Input = Input + { inputValue :: Either FilePath L.ByteString + , inputFilename :: Maybe FilePath + , inputContentType :: ContentType + } deriving (Show, Read) + +-- | hostname & port +type Host = (String, Int) -- ^ (hostname, port) + +-- | an HTTP Response +data Response + = Response { rsCode :: Int + , rsHeaders :: Headers + , rsFlags :: RsFlags + , rsBody :: L.ByteString + , rsValidator :: Maybe (Response -> IO Response) + } + | SendFile { rsCode :: Int + , rsHeaders :: Headers + , rsFlags :: RsFlags + , rsValidator :: Maybe (Response -> IO Response) + , sfFilePath :: FilePath -- ^ file handle to send from + , sfOffset :: Integer -- ^ offset to start at + , sfCount :: Integer -- ^ number of bytes to send + } + +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 (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 (showRsValidator (rsValidator res)) . + showString "\nsfFilePath = " . shows (sfFilePath res) . + showString "\nsfOffset = " . shows (sfOffset res) . + showString "\nsfCount = " . shows (sfCount res) + +showRsValidator :: Maybe (Response -> IO Response) -> String +showRsValidator = maybe "Nothing" (const "Just ") + +#if !MIN_VERSION_transformers(0,6,0) +-- what should the status code be ? +instance Error Response where + strMsg str = + setHeader "Content-Type" "text/plain; charset=UTF-8" $ + result 500 str +#endif + +-- | an HTTP request +data Request = Request + { rqSecure :: Bool -- ^ request uses https:\/\/ + , rqMethod :: Method -- ^ request method + , rqPaths :: [String] -- ^ the uri, split on /, and then decoded + , rqUri :: String -- ^ the raw rqUri + , rqQuery :: String -- ^ the QUERY_STRING + , rqInputsQuery :: [(String,Input)] -- ^ the QUERY_STRING decoded as key/value pairs + , rqInputsBody :: MVar [(String,Input)] -- ^ the request body decoded as key/value pairs (when appropriate) + , rqCookies :: [(String,Cookie)] -- ^ cookies + , rqVersion :: HttpVersion -- ^ HTTP version + , rqHeaders :: Headers -- ^ the HTTP request headers + , rqBody :: MVar RqBody -- ^ the raw, undecoded request body + , rqPeer :: Host -- ^ (hostname, port) of the client making the request + } + +instance Show Request where + showsPrec _ rq = + showString "================== Request =================" . + showString "\nrqSecure = " . shows (rqSecure rq) . + showString "\nrqMethod = " . shows (rqMethod rq) . + showString "\nrqPaths = " . shows (rqPaths rq) . + showString "\nrqUri = " . showString (rqUri rq) . + showString "\nrqQuery = " . showString (rqQuery rq) . + showString "\nrqInputsQuery = " . shows (rqInputsQuery rq) . + showString "\nrqInputsBody = " . showString "<>" . + showString "\nrqCookies = " . shows (rqCookies rq) . + showString "\nrqVersion = " . shows (rqVersion rq) . + showString "\nrqHeaders = " . shows (rqHeaders rq) . + showString "\nrqBody = " . showString "<>" . + showString "\nrqPeer = " . shows (rqPeer rq) + +-- | get the request body from the Request and replace it with Nothing +-- +-- IMPORTANT: You can really only call this function once. Subsequent +-- calls will return 'Nothing'. +takeRequestBody :: (MonadIO m) => Request -> m (Maybe RqBody) +takeRequestBody rq = liftIO $ tryTakeMVar (rqBody rq) + +-- | read the request body inputs +-- +-- This will only work if the body inputs have already been decoded. Otherwise it will return Nothing. +readInputsBody :: Request -> IO (Maybe [(String, Input)]) +readInputsBody req = + do mbi <- tryTakeMVar (rqInputsBody req) + case mbi of + (Just bi) -> + do putMVar (rqInputsBody req) bi + return (Just bi) + Nothing -> return Nothing + +-- | Converts a Request into a String representing the corresponding URL +rqURL :: Request -> String +rqURL rq = '/':intercalate "/" (rqPaths rq) ++ (rqQuery rq) + +-- | a class for working with types that contain HTTP headers +class HasHeaders a where + updateHeaders :: (Headers->Headers) -> a -> a -- ^ modify the headers + headers :: a -> Headers -- ^ extract the headers + +instance HasHeaders Response where + updateHeaders f rs = rs {rsHeaders=f $ rsHeaders rs } + headers = rsHeaders + +instance HasHeaders Request where + updateHeaders f rq = rq {rqHeaders = f $ rqHeaders rq } + headers = rqHeaders + +instance HasHeaders Headers where + updateHeaders f = f + headers = id + +-- | The body of an HTTP 'Request' +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. +setRsCode :: (Monad m) => Int -> Response -> m Response +setRsCode code rs = return rs { rsCode = code } + +-- | Takes a list of (key,val) pairs and converts it into Headers. The +-- keys will be converted to lowercase +mkHeaders :: [(String,String)] -> Headers +mkHeaders hdrs + = M.fromListWith join [ (P.pack (map toLower key), HeaderPair (P.pack key) [P.pack value]) | (key,value) <- hdrs ] + where join (HeaderPair key vs1) (HeaderPair _ vs2) = HeaderPair key (vs2++vs1) + +-------------------------------------------------------------- +-- Retrieving header information +-------------------------------------------------------------- + +-- | Lookup header value. Key is case-insensitive. +getHeader :: HasHeaders r => String -> r -> Maybe ByteString +getHeader = getHeaderBS . pack + +-- | Lookup header value. Key is a case-insensitive bytestring. +getHeaderBS :: HasHeaders r => ByteString -> r -> Maybe ByteString +getHeaderBS = getHeaderUnsafe . P.map toLower + +-- | Lookup header value with a case-sensitive key. The key must be lowercase. +getHeaderUnsafe :: HasHeaders r => ByteString -> r -> Maybe ByteString +getHeaderUnsafe key var = listToMaybe =<< fmap hValue (getHeaderUnsafe' key var) + +-- | Lookup header with a case-sensitive key. The key must be lowercase. +getHeaderUnsafe' :: HasHeaders r => ByteString -> r -> Maybe HeaderPair +getHeaderUnsafe' key = M.lookup key . headers + +-------------------------------------------------------------- +-- Querying header status +-------------------------------------------------------------- + +-- | Returns True if the associated key is found in the Headers. The lookup +-- is case insensitive. +hasHeader :: HasHeaders r => String -> r -> Bool +hasHeader key r = isJust (getHeader key r) + +-- | Acts as 'hasHeader' with ByteStrings +hasHeaderBS :: HasHeaders r => ByteString -> r -> Bool +hasHeaderBS key r = isJust (getHeaderBS key r) + +-- | Acts as 'hasHeaderBS' but the key is case sensitive. It should be +-- in lowercase. +hasHeaderUnsafe :: HasHeaders r => ByteString -> r -> Bool +hasHeaderUnsafe key r = isJust (getHeaderUnsafe' key r) + +checkHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> Bool +checkHeaderBS key val = checkHeaderUnsafe (P.map toLower key) (P.map toLower val) + +checkHeaderUnsafe :: HasHeaders r => ByteString -> ByteString -> r -> Bool +checkHeaderUnsafe key val r + = case getHeaderUnsafe key r of + Just val' | P.map toLower val' == val -> True + _ -> False + + +-------------------------------------------------------------- +-- Setting header status +-------------------------------------------------------------- + +-- | Associates the key/value pair in the headers. Forces the key to be +-- lowercase. +setHeader :: HasHeaders r => String -> String -> r -> r +setHeader key val = setHeaderBS (pack key) (pack val) + +-- | Acts as 'setHeader' but with ByteStrings. +setHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r +setHeaderBS key val = setHeaderUnsafe (P.map toLower key) (HeaderPair key [val]) + +-- | Sets the key to the HeaderPair. This is the only way to associate a key +-- with multiple values via the setHeader* functions. Does not force the key +-- to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. +setHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r +setHeaderUnsafe key val = updateHeaders (M.insert key val) + +-------------------------------------------------------------- +-- Adding headers +-------------------------------------------------------------- + +-- | Add a key/value pair to the header. If the key already has a value +-- associated with it, then the value will be appended. +-- Forces the key to be lowercase. +addHeader :: HasHeaders r => String -> String -> r -> r +addHeader key val = addHeaderBS (pack key) (pack val) + +-- | Acts as addHeader except for ByteStrings +addHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r +addHeaderBS key val = addHeaderUnsafe (P.map toLower key) (HeaderPair key [val]) + +-- | Add a key/value pair to the header using the underlying HeaderPair data +-- type. Does not force the key to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. +addHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r +addHeaderUnsafe key val = updateHeaders (M.insertWith join key val) + where join (HeaderPair k vs1) (HeaderPair _ vs2) = HeaderPair k (vs2++vs1) + +-- | Creates a Response with the given Int as the status code and the provided +-- String as the body of the Response +result :: Int -> String -> Response +result code = resultBS code . LU.fromString + +-- | Acts as 'result' but works with ByteStrings directly. +-- +-- By default, Transfer-Encoding: chunked will be used +resultBS :: Int -> L.ByteString -> Response +resultBS code s = Response code M.empty nullRsFlags s Nothing + +-- | Sets the Response's status code to the given Int and redirects to the given URI +redirect :: (ToSURI s) => Int -> s -> Response -> Response +redirect c s resp = setHeaderBS locationC (pack (render (toSURI s))) resp{rsCode = c} + +-- constants here + +-- | @Location@ +locationC :: ByteString +locationC = P.pack "Location" + +-- | @close@ +closeC :: ByteString +closeC = P.pack "close" + +-- | @Connection@ +connectionC :: ByteString +connectionC = P.pack "Connection" + +-- | @Keep-Alive@ +keepaliveC :: ByteString +keepaliveC = P.pack "Keep-Alive" + +readDec' :: (Num a, Eq a) => String -> a +readDec' s = + case readDec s of + [(n,[])] -> n + _ -> error "readDec' failed." + +-- | Read in any monad. +readM :: (MonadFail m, Read t) => String -> m t +readM s = case reads s of + [(v,"")] -> return v + _ -> fail "readM: parse error" + +-- |convert a 'ReadS a' result to 'Maybe a' +fromReadS :: [(a, String)] -> Maybe a +fromReadS [(n,[])] = Just n +fromReadS _ = Nothing + +-- | This class is used by 'path' to parse a path component into a +-- value. +-- +-- The instances for number types ('Int', 'Float', etc) use 'readM' to +-- parse the path component. +-- +-- The instance for 'String', on the other hand, returns the +-- unmodified path component. +-- +-- See the following section of the Happstack Crash Course for +-- detailed instructions using and extending 'FromReqURI': +-- +-- + +class FromReqURI a where + fromReqURI :: String -> Maybe a + +instance FromReqURI String where fromReqURI = Just +instance FromReqURI Text.Text where fromReqURI = fmap fromString . fromReqURI +instance FromReqURI Lazy.Text where fromReqURI = fmap fromString . fromReqURI +instance FromReqURI Char where fromReqURI s = case s of [c] -> Just c ; _ -> Nothing +instance FromReqURI Int where fromReqURI = fromReadS . readSigned readDec +instance FromReqURI Int8 where fromReqURI = fromReadS . readSigned readDec +instance FromReqURI Int16 where fromReqURI = fromReadS . readSigned readDec +instance FromReqURI Int32 where fromReqURI = fromReadS . readSigned readDec +instance FromReqURI Int64 where fromReqURI = fromReadS . readSigned readDec +instance FromReqURI Integer where fromReqURI = fromReadS . readSigned readDec +instance FromReqURI Word where fromReqURI = fromReadS . readDec +instance FromReqURI Word8 where fromReqURI = fromReadS . readDec +instance FromReqURI Word16 where fromReqURI = fromReadS . readDec +instance FromReqURI Word32 where fromReqURI = fromReadS . readDec +instance FromReqURI Word64 where fromReqURI = fromReadS . readDec +instance FromReqURI Float where fromReqURI = readM +instance FromReqURI Double where fromReqURI = readM +instance FromReqURI Bool where + fromReqURI s = + let s' = map toLower s in + case s' of + "0" -> Just False + "false" -> Just False + "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/JSON.hs b/src/Happstack/Server/JSON.hs deleted file mode 100644 --- a/src/Happstack/Server/JSON.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Happstack.Server.JSON where -import Data.Char -import Data.List - -data JSON = JBool Bool | JString String | JInt Int | JFloat Float | - JObj [(String,JSON)] | JList [JSON] | JNull - - -jInt :: Integral a => a -> JSON -jInt = JInt . fromIntegral - -class ToJSON a where - toJSON::a->JSON -instance ToJSON JSON where toJSON=id - -jsonToString :: JSON -> String -jsonToString (JBool bool) = map toLower $ show bool -jsonToString (JString string) = show string -jsonToString (JInt int) = show int -jsonToString (JFloat float) = show float -jsonToString (JObj pairs) = '{' : (concat $ (intersperse "," $ map impl pairs) )++"}" - where - impl (name,val) = concat [show name,":",jsonToString val] -jsonToString (JList list) = - '[':(concat $ (intersperse "," $ map jsonToString list)) ++"]" -jsonToString JNull = "null" -type CallBack=String - -data JSONCall x = JCall CallBack x diff --git a/src/Happstack/Server/MessageWrap.hs b/src/Happstack/Server/MessageWrap.hs deleted file mode 100644 --- a/src/Happstack/Server/MessageWrap.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} - -module Happstack.Server.MessageWrap where - -import Control.Monad.Identity -import qualified Data.ByteString.Char8 as P -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.List as List -import Data.Maybe -import Happstack.Server.HTTP.Types as H -import Happstack.Server.HTTP.Multipart -import Happstack.Server.SURI as SURI -import Happstack.Util.Common - -queryInput :: SURI -> [(String, Input)] -queryInput uri = formDecode (case SURI.query $ uri of - '?':r -> r - xs -> xs) - -bodyInput :: Request -> [(String, Input)] -bodyInput req | rqMethod req /= POST = [] -bodyInput req = - let ctype = getHeader "content-type" req >>= parseContentType . P.unpack - getBS (Body bs) = bs - in decodeBody ctype (getBS $ rqBody req) - - --- Decodes application\/x-www-form-urlencoded inputs. -formDecode :: String -> [(String, Input)] -formDecode [] = [] -formDecode qString = - if null pairString then rest else - (SURI.unEscape name,simpleInput $ SURI.unEscape val):rest - where (pairString,qString')= split (=='&') qString - (name,val)=split (=='=') pairString - rest=if null qString' then [] else formDecode qString' - -decodeBody :: Maybe ContentType - -> L.ByteString - -> [(String,Input)] -decodeBody ctype inp - = case ctype of - Just (ContentType "application" "x-www-form-urlencoded" _) - -> formDecode (L.unpack inp) - Just (ContentType "multipart" "form-data" ps) - -> multipartDecode ps inp - Just _ -> [] -- unknown content-type, the user will have to - -- deal with it by looking at the raw content - -- No content-type given, assume x-www-form-urlencoded - Nothing -> formDecode (L.unpack inp) - --- | Decodes multipart\/form-data input. -multipartDecode :: [(String,String)] -- ^ Content-type parameters - -> L.ByteString -- ^ Request body - -> [(String,Input)] -- ^ Input variables and values. -multipartDecode ps inp = - case lookup "boundary" ps of - Just b -> case parseMultipartBody b inp of - Just (MultiPart bs) -> map bodyPartToInput bs - Nothing -> [] -- FIXME: report parse error - Nothing -> [] -- FIXME: report that there was no boundary - -bodyPartToInput :: BodyPart -> (String,Input) -bodyPartToInput (BodyPart hs b) = - case getContentDisposition hs of - Just (ContentDisposition "form-data" ps) -> - (fromMaybe "" $ lookup "name" ps, - Input { inputValue = b, - inputFilename = lookup "filename" ps, - inputContentType = ctype }) - _ -> ("ERROR",simpleInput "ERROR") -- FIXME: report error - where ctype = fromMaybe defaultInputType (getContentType hs) - - -simpleInput :: String -> Input -simpleInput v - = Input { inputValue = L.pack v - , inputFilename = Nothing - , inputContentType = defaultInputType - } - --- | The default content-type for variables. -defaultInputType :: ContentType -defaultInputType = ContentType "text" "plain" [] -- FIXME: use some default encoding? - --- | Get the path components from a String. -pathEls :: String -> [String] -pathEls = (drop 1) . map SURI.unEscape . splitList '/' - --- | Like 'Read' except Strings and Chars not quoted. -class (Read a)=>ReadString a where readString::String->a; readString =read - -instance ReadString Int -instance ReadString Double -instance ReadString Float -instance ReadString SURI.SURI where readString = read . show -instance ReadString [Char] where readString=id -instance ReadString Char where - readString s= if length t==1 then head t else read t where t=trim s diff --git a/src/Happstack/Server/MinHaXML.hs b/src/Happstack/Server/MinHaXML.hs deleted file mode 100644 --- a/src/Happstack/Server/MinHaXML.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# LANGUAGE TemplateHaskell, FlexibleInstances, - OverlappingInstances, UndecidableInstances, TypeSynonymInstances #-} - - - -module Happstack.Server.MinHaXML where --- Copyright (c) Happstack.com 2009; (c) HAppS.org 2005. All Rights Reserved. - -import Prelude hiding (elem, pi) - -import Text.XML.HaXml.Types as Types -import Text.XML.HaXml.Escape -import Text.XML.HaXml.Pretty as Pretty -import Text.XML.HaXml.Verbatim as Verbatim -import Happstack.Util.Common -import Data.Maybe -import System.Time - -import Happstack.Data.Xml as Xml -import Happstack.Data.Xml.HaXml - -type StyleURL=String -data StyleSheet = NoStyle - | CSS {styleURL::StyleURL} - | XSL {styleURL::StyleURL} deriving (Read,Show) -hasStyleURL :: StyleSheet -> Bool -hasStyleURL NoStyle = False -hasStyleURL _ = True -type Element = Types.Element - - - -isCSS :: StyleSheet -> Bool -isCSS (CSS _)=True -isCSS _ = False -isXSL :: StyleSheet -> Bool -isXSL = not.isCSS - -t :: Name -> [(Name, String)] -> CharData -> Types.Element -t=textElem -l :: Name -> [(Name, String)] -> [Types.Element] -> Types.Element -l=listElem -e :: Name -> [(Name, String)] -> Types.Element -e=emptyElem -( [(Name, String)] - -> [Types.Element] - -> Types.Element -() :: Name -> [(Name, String)] -> CharData -> Types.Element -(<>)=t - - - -xmlElem :: (t -> [Content]) - -> Name - -> [(Name, String)] - -> t - -> Types.Element -xmlElem f = \name attrs val -> xmlelem name attrs (f val) - where - xmlelem name = Types.Elem name . map (uncurry attr) - attr name val= (name,AttValue [Left val]) - -textElem :: Name -> [(Name, String)] -> CharData -> Types.Element -textElem = xmlElem (return.CString True) -emptyElem :: Name -> [(Name, String)] -> Types.Element -emptyElem = \n a->xmlElem id n a [] -listElem :: Name - -> [(Name, String)] - -> [Types.Element] - -> Types.Element -listElem = xmlElem $ map CElem - -cdataElem :: CharData -> Content -cdataElem = CString False - --- Document (simpleProlog xsl) [] $ xmlEscape stdXmlEscaper root -simpleDocOld :: StyleSheet -> Types.Element -> String -simpleDocOld xsl = show . document . - flip (Document (simpleProlog xsl) []) [] . xmlStdEscape - -simpleDoc :: StyleSheet -> Types.Element -> String -simpleDoc style elem = ("\n"++ - if hasStyleURL style then pi else "") ++ - (verbatim $ xmlStdEscape elem) - where typeText=if isCSS style then "text/css" else "text/xsl" - pi= "\n" - - -simpleDoc' :: StyleSheet -> Types.Element -> String -simpleDoc' style elem = (if hasStyleURL style then pi else "") ++ - (verbatim $ xmlStdEscape elem) - where typeText=if isCSS style then "text/css" else "text/xsl" - pi= "\n" - - - -xmlEscaper :: XmlEscaper -xmlEscaper=stdXmlEscaper -xmlStdEscape :: Types.Element -> Types.Element -xmlStdEscape = xmlEscape stdXmlEscaper -verbim :: (Verbatim a) => a -> String -verbim = verbatim - -simpleProlog :: StyleSheet -> Prolog -simpleProlog style = - Prolog - (Just (XMLDecl "1.0" - (Just $ EncodingDecl "UTF-8") - Nothing -- standalone declaration - )) - [] Nothing - (if url=="" then [] else [pi]) - where - pi = PI ("xml-stylesheet", "type=\""++typeText++"\" href=\""++url++"\"") - typeText = if isCSS style then "text/css" else "text/xsl" - url=if hasStyleURL style then styleURL style else "" - -nonEmpty :: Name -> String -> Maybe Types.Element -nonEmpty name val = if val=="" then Nothing - else Just $ textElem name [] val - -getRoot :: Document -> Types.Element -getRoot (Document _ _ root _) = root - ---toXML .< "App" attrs ./> ---toXML .< "App" attrs .> [] -data XML a = XML StyleSheet a - -class ToElement x where toElement::x->Types.Element - -instance (ToElement x) => ToElement (Maybe x) where - toElement = maybe (emptyElem "Nothing" []) toElement - -instance ToElement String where toElement = textElem "String" [] -instance ToElement Types.Element where toElement = id -instance ToElement CalendarTime where - toElement = recToEl "CalendarTime" - [attrFS "year" ctYear - ,attrFS "month" (fromEnum.ctMonth) - ,attrFS "day" ctDay - ,attrFS "hour" ctHour - ,attrFS "min" ctMin - ,attrFS "sec" ctSec - ,attrFS "time" time - ] [] - where time = epochPico - -instance ToElement Int where toElement = toElement . show -instance ToElement Integer where toElement = toElement . show -instance ToElement Float where toElement = toElement . show -instance ToElement Double where toElement = toElement . show - - -instance (Xml a) => ToElement a where - toElement = un . head . map toHaXml . toXml - where - un (CElem el) = el - un _ = error "Case not handled in Xml toElement instance" - -wrapElem :: (ToElement x) => Name -> x -> Types.Element -wrapElem tag x= listElem tag [] [toElement x] -elF :: (ToElement b) => Name -> (a -> b) -> a -> Types.Element -elF tag f = wrapElem tag.f --- label !<=! field = wrapField label field -attrF :: t1 -> (t -> String) -> t -> (t1, String) -attrF name f rec = (name,quoteEsc $ f rec) -attrFS :: (Show a) => t1 -> (t -> a) -> t -> (t1, String) -attrFS name f rec = (name,quoteEsc $ show $ f rec) -attrFMb :: (a -> String) - -> String - -> (a1 -> Maybe a) - -> a1 - -> (String, String) -attrFMb r name f = maybe ("","") (\x->(name,quoteEsc $ r x)) . f - ---(\x->(name,quoteEsc $ r x)) . f ---(name,quoteEsc $ show $ f rec) - -quoteEsc :: String -> String -quoteEsc [] = [] -quoteEsc ('"':list) = """ ++ quoteEsc list -quoteEsc (x:xs) = x:quoteEsc xs - ---quotescape \\ and " \" - -recToEl :: Name - -> [a -> (String, String)] - -> [a -> Types.Element] - -> a - -> Types.Element -recToEl name attrs els rec = listElem name attrs' (revmap rec els) - where - attrs' = filter (\ (x,_)->not $ null x) (revmap rec attrs) -listToEl :: (ToElement a) => - Name -> [(Name, String)] -> [a] -> Types.Element -listToEl name attrs = listElem name attrs . map toElement - -toAttrs :: t -> [(t1, t -> t2)] -> [(t1, t2)] -toAttrs x = map (\ (s,f)->(s, f x)) - -{-- -toElement rules: -1. if the attr is an instance of toElement then it is a child. -2. if it named and is type string then it is shown that way. -3. if it named and has non-string type then use show on the value. -4. if the attributes are not named then use the type as the label and - make the text child be a show of the object. ---} - - -newtype ElString = ElString {elString::String} deriving (Eq,Ord,Read,Show) diff --git a/src/Happstack/Server/Monads.hs b/src/Happstack/Server/Monads.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Monads.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE FlexibleContexts, CPP #-} +-- | This module provides four classes and some related functions +-- which provide 'ServerPartT' with much of its web-centric behavior. +-- +-- 1. 'ServerMonad' provides access to the HTTP 'Request' +-- +-- 2. 'FilterMonad' provides the ability to apply filters and transformations to a 'Response' +-- +-- 3. 'WebMonad' provides a way to escape a computation early and return a 'Response' +-- +-- 4. 'HasRqData' which provides access to the decoded QUERY_STRING and request body/form data +module Happstack.Server.Monads + ( -- * ServerPartT + ServerPartT + , ServerPart + -- * Happstack class + , Happstack + -- * ServerMonad + , ServerMonad(..) + , mapServerPartT + , mapServerPartT' + , UnWebT + , filterFun + -- * FilterMonad + , FilterMonad(..) + , ignoreFilters + , addHeaderM + , getHeaderM + , setHeaderM + , neverExpires + -- * WebMonad + , WebMonad(..) + , escape + , escape' + -- * MonadPlus helpers + , require + , requireM + -- * escapeHTTP + , escapeHTTP + ) where + +import Control.Applicative (Alternative, Applicative) +import Control.Monad (MonadPlus(mzero)) +#if !MIN_VERSION_transformers(0,6,0) +import Control.Monad.Trans.Error (Error, ErrorT) +#endif +import Control.Monad.Trans (MonadIO(..),MonadTrans(lift)) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Reader (ReaderT) +import qualified Control.Monad.Writer.Lazy as Lazy (WriterT) +import qualified Control.Monad.Writer.Strict as Strict (WriterT) +import qualified Control.Monad.State.Lazy as Lazy (StateT) +import qualified Control.Monad.State.Strict as Strict (StateT) +import qualified Control.Monad.RWS.Lazy as Lazy (RWST) +import qualified Control.Monad.RWS.Strict as Strict (RWST) +import qualified Data.ByteString.Char8 as B +import Data.Monoid (Monoid) +import Happstack.Server.Internal.Monads +import Happstack.Server.Types (Response, addHeader, getHeader, setHeader) +import Happstack.Server.RqData (HasRqData) + +-- | A class alias for all the classes a standard server monad (such as 'ServerPartT') is expected to have instances for. This allows you to keep your type signatures shorter and easier to understand. +class ( ServerMonad m, WebMonad Response m, FilterMonad Response m + , MonadIO m, MonadPlus m, HasRqData m, Monad m, Functor m + , Applicative m, Alternative m) => Happstack m + +instance (Functor m, Monad m, MonadPlus m + , MonadIO m) => Happstack (ServerPartT m) +instance (Happstack m) => Happstack (Lazy.StateT s m) +instance (Happstack m) => Happstack (Strict.StateT s m) +instance (Happstack m) => Happstack (ReaderT r m) +instance (Happstack m, Monoid w) => Happstack (Lazy.WriterT w m) +instance (Happstack m, Monoid w) => Happstack (Strict.WriterT w m) +instance (Happstack m, Monoid w) => Happstack (Lazy.RWST r w s m) +instance (Happstack m, Monoid w) => Happstack (Strict.RWST r w s m) +#if !MIN_VERSION_transformers(0,6,0) +instance (Happstack m, Error e) => Happstack (ErrorT e m) +#endif +instance (Happstack m, Monoid e) => Happstack (ExceptT e m) + +-- | Get a header out of the request. +getHeaderM :: (ServerMonad m) => String -> m (Maybe B.ByteString) +getHeaderM a = askRq >>= return . (getHeader a) + +-- | Add headers into the response. This method does not overwrite +-- any existing header of the same name, hence the name 'addHeaderM'. +-- If you want to replace a header use 'setHeaderM'. +addHeaderM :: (FilterMonad Response m) => String -> String -> m () +addHeaderM a v = composeFilter $ \res-> addHeader a v res + +-- | Set a header into the response. This will replace an existing +-- header of the same name. Use 'addHeaderM' if you want to add more +-- than one header of the same name. +setHeaderM :: (FilterMonad Response m) => String -> String -> m () +setHeaderM a v = composeFilter $ \res -> setHeader a v res + +-- | Set a far-future Expires header. Useful for static resources. If the +-- browser has the resource cached, no extra request is spent. +neverExpires :: (FilterMonad Response m) => m () +neverExpires = setHeaderM "Expires" "Mon, 31 Dec 2035 12:00:00 GMT" + +-- | Run an 'IO' action and, if it returns 'Just', pass it to the +-- second argument. +require :: (MonadIO m, MonadPlus m) => IO (Maybe a) -> (a -> m r) -> m r +require fn handle = do + mbVal <- liftIO fn + case mbVal of + Nothing -> mzero + Just a -> handle a + +-- | A variant of require that can run in any monad, not just 'IO'. +requireM :: (MonadTrans t, Monad m, MonadPlus (t m)) => m (Maybe a) -> (a -> t m r) -> t m r +requireM fn handle = do + mbVal <- lift fn + case mbVal of + Nothing -> mzero + Just a -> handle a + diff --git a/src/Happstack/Server/Parts.hs b/src/Happstack/Server/Parts.hs deleted file mode 100644 --- a/src/Happstack/Server/Parts.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-} -module Happstack.Server.Parts( - compressedResponseFilter - ,gzipFilter - ,deflateFilter - ,encodings -) where -import Happstack.Server.SimpleHTTP -import Text.ParserCombinators.Parsec -import Control.Monad -import Data.Maybe -import Data.List -import qualified Data.ByteString.Char8 as BS -import qualified Codec.Compression.GZip as GZ -import qualified Codec.Compression.Zlib as Z - --- | reads the \"Accept-Encoding\" header. Then, if possible --- will compress the response body with methods "gzip" or "deflate" --- --- Returns the name of the coding chosen -compressedResponseFilter:: - (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m) - => m String -compressedResponseFilter = do - mbAccept<-getHeaderM "Accept-Encoding" - accept<- maybe mzero return mbAccept - let eEncoding = bestEncoding $ BS.unpack accept - (coding,action) <- case eEncoding of - Left _ -> do - setResponseCode 406 - finishWith $ toResponse "" - Right a -> return (a, maybe (fail "Encoding returned not in the list of known encodings") - id (lookup a allEncodingHandlers)) - setHeaderM "Content-Encoding" coding - action - return coding - --- | compresses the body of the response with gzip. --- does not set any headers. -gzipFilter::(FilterMonad Response m) => m() -gzipFilter = do - composeFilter (\r -> r{rsBody = GZ.compress $ rsBody r}) - --- | compresses the body of the response with zlib's --- deflate method --- does not set any headers. -deflateFilter::(FilterMonad Response m) => m() -deflateFilter = do - composeFilter (\r -> r{rsBody = Z.compress $ rsBody r}) - --- | based on the rules describe in rfc2616 sec. 14.3 -bestEncoding :: String -> Either String String -bestEncoding encs = do - encList<-either (Left . show) (Right) $ parse encodings "" encs - case acceptable encList of - [] -> Left "no encoding found" - a -> Right $ head a - where - -- first intersect with the list of encodings we know how to deal with at all - knownEncodings:: [(String,Maybe Double)] -> [(String, Maybe Double)] - knownEncodings m = intersectBy (\x y->fst x == fst y) m (map (\x -> (x,Nothing)) allEncodings) - -- this expands the wildcard, by figuring out if we need to include "identity" in the list - -- Then it deletes the wildcard entry, drops all the "q=0" entries (which aren't allowed). - -- - -- note this implementation is a little conservative. if someone were to specify "*" - -- without a "q" value, it would be this server is willing to accept any format at all. - -- We pretty much assume we can't send them /any/ format and that they really - -- meant just "identity" this seems safe to me. - knownEncodings':: [(String,Maybe Double)] -> [(String, Maybe Double)] - knownEncodings' m = filter dropZero $ deleteBy (\(a,_) (b,_)->a==b) ("*",Nothing) $ - case lookup "*" (knownEncodings m) of - Nothing -> addIdent $ knownEncodings m - Just (Just a) | a>0 -> addIdent $ knownEncodings m - | otherwise -> knownEncodings m - Just (Nothing) -> addIdent $ knownEncodings m - dropZero (_, Just a) | a==0 = False - | otherwise = True - dropZero (_, Nothing) = True - addIdent:: [(String,Maybe Double)] -> [(String, Maybe Double)] - addIdent m = if isNothing $ lookup "identity" m - then m ++ [("identity",Nothing)] - else m - -- finally we sort the list of available encodings. - acceptable:: [(String,Maybe Double)] -> [String] - acceptable l = map fst $ sortBy (flip cmp) $ knownEncodings' l - -- let the client choose but break ties with gzip - encOrder = reverse $ zip (reverse allEncodings) [1..] - m0 = maybe (0.0::Double) id - cmp (s,mI) (t,mJ) | m0 mI == m0 mJ - = compare (m0 $ lookup s encOrder) (m0 $ lookup t encOrder) - | otherwise = compare (m0 mI) (m0 mJ) - - -allEncodingHandlers:: (FilterMonad Response m) => [(String, m ())] -allEncodingHandlers = zip allEncodings handlers - -allEncodings :: [String] -allEncodings = - ["gzip" - ,"x-gzip" --- ,"compress" -- as far as I can tell there is no haskell library that supports this --- ,"x-compress" -- as far as I can tell, there is no haskell library that supports this - ,"deflate" - ,"identity" - ,"*" - ] - -handlers::(FilterMonad Response m) => [m ()] -handlers = - [gzipFilter - ,gzipFilter --- ,compressFilter --- ,compressFilter - ,deflateFilter - ,return () - ,fail $ "chose * as content encoding" - ] - --- | unsupported: a parser for the Accept-Encoding header -encodings :: GenParser Char st [([Char], Maybe Double)] -encodings = ws >> (encoding1 `sepBy` try sep) >>= (\x -> ws >> eof >> return x) - where - ws = many space - sep = do - ws - char ',' - ws - encoding1 :: GenParser Char st ([Char], Maybe Double) - encoding1 = do - encoding <- many1 letter <|> string "*" - ws - quality<-optionMaybe qual - return (encoding, fmap read quality) - qual = do - char ';' >> ws >> char 'q' >> ws >> char '=' >> ws - q<-float - return $ q - int = many1 digit - float = do - wholePart<-many1 digit - fractionalPart<-option "" fraction - return $ wholePart ++ fractionalPart - <|> - do - fractionalPart<-fraction - return $ fractionalPart - fraction :: GenParser Char st String - fraction = do - char '.' - fractionalPart<-option "" int - return $ '.':fractionalPart - - diff --git a/src/Happstack/Server/Response.hs b/src/Happstack/Server/Response.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Response.hs @@ -0,0 +1,334 @@ +{-# 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 + , toResponseBS + -- * Setting the Response Code + , ok + , noContent + , internalServerError + , badGateway + , badRequest + , unauthorized + , forbidden + , notFound + , prettyResponse + , requestEntityTooLarge + , seeOther + , found + , movedPermanently + , tempRedirect + , setResponseCode + , resp + -- * Handling if-modified-since + , 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) +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import Data.Time (UTCTime, formatTime, defaultTimeLocale) +import Happstack.Server.Internal.Monads (FilterMonad(composeFilter)) +import Happstack.Server.Internal.Types +import Happstack.Server.Types (Response(..), Request(..), nullRsFlags, getHeader, noContentLength, redirect, result, setHeader, setHeaderBS) +import Happstack.Server.SURI (ToSURI) +import 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 +-- > +-- > main = simpleHTTP nullConf $ ok $ toResponseBS (C.pack "text/plain") (L.pack "hello, world") +-- +-- (note: 'C.pack' and 'L.pack' only work for ascii. For unicode strings you would need to use @utf8-string@, @text@, or something similar to create a valid 'ByteString'). +toResponseBS :: B.ByteString -- ^ content-type + -> L.ByteString -- ^ response body + -> Response +toResponseBS contentType message = + let res = Response 200 M.empty nullRsFlags message Nothing + in setHeaderBS (B.pack "Content-Type") contentType res + + +-- | 'toResponse' will convert a value into a 'Response' body, +-- set the @content-type@, and set the default response code for that type. +-- +-- @happstack-server@ Example: +-- +-- > main = simpleHTTP nullConf $ toResponse "hello, world!" +-- +-- will generate a 'Response' with the content-type @text/plain@, +-- the response code @200 OK@, and the body: @hello, world!@. +-- +-- 'simpleHTTP' will call 'toResponse' automatically, so the above can be shortened to: +-- +-- > main = simpleHTTP nullConf $ "hello, world!" +-- +-- @happstack-lite@ Example: +-- +-- > main = serve Nothing $ toResponse "hello, world!" +-- +-- Minimal definition: 'toMessage' (and usually 'toContentType'). +class ToMessage a where + 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 val = + let bs = toMessage val + res = Response 200 M.empty nullRsFlags bs Nothing + in setHeaderBS (B.pack "Content-Type") (toContentType val) + res +{- +instance ToMessage [Element] where + toContentType _ = B.pack "application/xml; charset=UTF-8" + toMessage [el] = LU.fromString $ H.simpleDoc H.NoStyle $ toHaXmlEl el -- !! OPTIMIZE + toMessage x = error ("Happstack.Server.SimpleHTTP 'instance ToMessage [Element]' Can't handle " ++ show x) +-} + +instance ToMessage () where + toContentType _ = B.pack "text/plain" + toMessage () = L.empty + +instance ToMessage String where + toContentType _ = B.pack "text/plain; charset=UTF-8" + toMessage = LU.fromString + +instance ToMessage T.Text where + toContentType _ = B.pack "text/plain; charset=UTF-8" + toMessage t = L.fromChunks [T.encodeUtf8 t] + +instance ToMessage LT.Text where + toContentType _ = B.pack "text/plain; charset=UTF-8" + toMessage = LT.encodeUtf8 + +instance ToMessage Integer where + toMessage = toMessage . show + +instance ToMessage a => ToMessage (Maybe a) where + toContentType _ = toContentType (undefined :: a) + toMessage Nothing = toMessage "nothing" + toMessage (Just x) = toMessage x + +instance ToMessage Html where + toContentType _ = B.pack "text/html; charset=UTF-8" + toMessage = LU.fromString . renderHtml + +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 + +instance ToMessage Response where + toResponse = id + +instance ToMessage L.ByteString where + toResponse bs = Response 200 M.empty nullRsFlags bs Nothing + +instance ToMessage B.ByteString where + toResponse bs = toResponse (L.fromChunks [bs]) + +{- + +-- This instances causes awful error messages. I am removing it and +-- seeing if anyone complains. I doubt they will. + +instance (Xml a)=>ToMessage a where + toContentType = toContentType . toXml + toMessage = toMessage . toPublicXml +-} + +-- toMessageM = toMessageM . toPublicXml + +-- | alias for: @fmap toResponse@ +-- +-- turns @m a@ into @m 'Response'@ using 'toResponse'. +-- +-- > main = simpleHTTP nullConf $ flatten $ do return "flatten me." +flatten :: (ToMessage a, Functor f) => f a -> f Response +flatten = fmap toResponse + + +-- |Honor an @if-modified-since@ header in a 'Request'. +-- If the 'Request' includes the @if-modified-since@ header and the +-- 'Response' has not been modified, then return 304 (Not Modified), +-- otherwise return the 'Response'. +ifModifiedSince :: UTCTime -- ^ mod-time for the 'Response' (MUST NOT be later than server's time of message origination) + -> Request -- ^ incoming request (used to check for if-modified-since) + -> Response -- ^ Response to send if there are modifications + -> Response +ifModifiedSince modTime request response = + let repr = formatTime defaultTimeLocale "%a, %d %b %Y %X GMT" modTime + notmodified = getHeader "if-modified-since" request == Just (B.pack $ repr) + in if notmodified + then noContentLength $ result 304 "" -- Not Modified + else setHeader "Last-modified" repr response + +-- | Deprecated: use 'composeFilter'. +modifyResponse :: (FilterMonad a m) => (a -> a) -> m() +modifyResponse = composeFilter +{-# DEPRECATED modifyResponse "Use composeFilter" #-} + +-- | Set an arbitrary return code in your response. +-- +-- 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 => + 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. +-- +-- > main = simpleHTTP nullConf $ resp 200 "Everything is OK" +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 + +-- | Respond with @204 No Content@ +-- +-- A @204 No Content@ response may not contain a message-body. If you try to supply one, it will be dutifully ignored. +-- +-- > main = simpleHTTP nullConf $ noContent "This will be ignored." +noContent :: (FilterMonad Response m) => a -> m a +noContent val = composeFilter (\r -> noContentLength (r { rsCode = 204, rsBody = L.empty })) >> return val + +-- | Respond with @301 Moved Permanently@. +-- +-- > main = simpleHTTP nullConf $ movedPermanently "http://example.org/" "What you are looking for is now at http://example.org/" +movedPermanently :: (FilterMonad Response m, ToSURI a) => a -> res -> m res +movedPermanently uri res = do modifyResponse $ redirect 301 uri + 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 + return res + +-- | Respond with @303 See Other@. +-- +-- > main = simpleHTTP nullConf $ seeOther "http://example.org/" "What you are looking for is now at http://example.org/" +-- +-- NOTE: The second argument of 'seeOther' is the message body which will sent to the browser. According to the HTTP 1.1 spec, +-- +-- @the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s).@ +-- +-- This is because pre-HTTP\/1.1 user agents do not support 303. However, in practice you can probably just use @\"\"@ as the second argument. +seeOther :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res +seeOther uri res = do modifyResponse $ redirect 303 uri + return res + +-- | Respond with @307 Temporary Redirect@. +-- +-- > main = simpleHTTP nullConf $ tempRedirect "http://example.org/" "What you are looking for is temporarily at http://example.org/" +tempRedirect :: (FilterMonad Response m, ToSURI a) => a -> res -> m res +tempRedirect val res = do modifyResponse $ redirect 307 val + return res + +-- | Respond with @400 Bad Request@. +-- +-- > main = simpleHTTP nullConf $ badRequest "Bad Request." +badRequest :: (FilterMonad Response m) => a -> m a +badRequest = resp 400 + +-- | Respond with @401 Unauthorized@. +-- +-- > main = simpleHTTP nullConf $ unauthorized "You are not authorized." +unauthorized :: (FilterMonad Response m) => a -> m a +unauthorized = resp 401 + +-- | Respond with @403 Forbidden@. +-- +-- > main = simpleHTTP nullConf $ forbidden "Sorry, it is forbidden." +forbidden :: (FilterMonad Response m) => a -> m a +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 + +-- | Respond with @413 Request Entity Too Large@. +-- +-- > main = simpleHTTP nullConf $ requestEntityTooLarge "That's too big for me to handle." +requestEntityTooLarge :: (FilterMonad Response m) => a -> m a +requestEntityTooLarge = resp 413 + +-- | Respond with @500 Internal Server Error@. +-- +-- > main = simpleHTTP nullConf $ internalServerError "Sorry, there was an internal server error." +internalServerError :: (FilterMonad Response m) => a -> m a +internalServerError = resp 500 + +-- | Responds with @502 Bad Gateway@. +-- +-- > main = simpleHTTP nullConf $ badGateway "Bad Gateway." +badGateway :: (FilterMonad Response m) => a -> m a +badGateway = resp 502 + +-- | 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 = " $ 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 (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 new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Routing.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE FlexibleInstances, PatternGuards, ScopedTypeVariables, TypeSynonymInstances #-} +-- | Route an incoming 'Request' to a handler. For more in-depth documentation see this section of the Happstack Crash Course: +module Happstack.Server.Routing + ( -- * Route by scheme + http + , https + -- * Route by request method + , methodM + , methodOnly + , methodSP + , method + , MatchMethod(..) + -- * Route by pathInfo + , dir + , dirs + , nullDir + , trailingSlash + , noTrailingSlash + , anyPath + , path + , uriRest + -- * Route by host + , host + , withHost + -- * Route by (Request -> Bool) + , guardRq + ) where + +import Control.Monad (MonadPlus(mzero), unless) +import qualified Data.ByteString.Char8 as B +import Happstack.Server.Monads (ServerMonad(..)) +import Happstack.Server.Types (Request(..), Method(..), FromReqURI(..), getHeader, rqURL) +import System.FilePath (makeRelative, splitDirectories) + +-- | instances of this class provide a variety of ways to match on the 'Request' method. +-- +-- Examples: +-- +-- > method GET -- match GET or HEAD +-- > method [GET, POST] -- match GET, HEAD or POST +-- > method HEAD -- match HEAD /but not/ GET +-- > method (== GET) -- match GET or HEAD +-- > method (not . (==) DELETE) -- match any method except DELETE +-- > method () -- match any method +-- +-- As you can see, GET implies that HEAD should match as well. This is to +-- make it harder to write an application that uses HTTP incorrectly. +-- Happstack handles HEAD requests automatically, but we still need to make +-- sure our handlers don't mismatch or a HEAD will result in a 404. +-- +-- If you must, you can still do something like this +-- to match GET without HEAD: +-- +-- > guardRq ((== GET) . rqMethod) + +class MatchMethod m where + matchMethod :: m -> Method -> Bool + +instance MatchMethod Method where + matchMethod m = matchMethod (== m) + +instance MatchMethod [Method] where + matchMethod ms m = any (`matchMethod` m) ms + +instance MatchMethod (Method -> Bool) where + matchMethod f HEAD = f HEAD || f GET + matchMethod f m = f m + +instance MatchMethod () where + matchMethod () _ = True + +------------------------------------- +-- guards + +-- | Guard using an arbitrary function on the 'Request'. +guardRq :: (ServerMonad m, MonadPlus m) => (Request -> Bool) -> m () +guardRq f = do + rq <- askRq + unless (f rq) mzero + + +-- | guard which checks that an insecure connection was made via http:\/\/ +-- +-- Example: +-- +-- > handler :: ServerPart Response +-- > handler = +-- > do http +-- > ... +http :: (ServerMonad m, MonadPlus m) => m () +http = guardRq (not . rqSecure) + + +-- | guard which checks that a secure connection was made via https:\/\/ +-- +-- Example: +-- +-- > handler :: ServerPart Response +-- > handler = +-- > do https +-- > ... +https :: (ServerMonad m, MonadPlus m) => m () +https = guardRq rqSecure + + +-- | Guard against the method only (as opposed to 'methodM'). +-- +-- Example: +-- +-- > handler :: ServerPart Response +-- > handler = +-- > do method [GET, HEAD] +-- > ... +method :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m () +method meth = guardRq $ \rq -> matchMethod meth (rqMethod rq) + +-- | Guard against the method. This function also guards against +-- *any remaining path segments*. See 'method' for the version +-- that guards only by method. +-- +-- Example: +-- +-- > handler :: ServerPart Response +-- > handler = +-- > do methodM [GET, HEAD] +-- > ... +-- +-- NOTE: This function is largely retained for backwards +-- compatibility. The fact that implicitly calls 'nullDir' is often +-- forgotten and leads to confusion. It is probably better to just use +-- 'method' and call 'nullDir' explicitly. +-- +-- This function will likely be deprecated in the future. +methodM :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m () +methodM meth = methodOnly meth >> nullDir + +-- | Guard against the method only (as opposed to 'methodM'). +-- +-- Example: +-- +-- > handler :: ServerPart Response +-- > handler = +-- > do methodOnly [GET, HEAD] +-- > ... +methodOnly :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m () +methodOnly = method +{-# DEPRECATED methodOnly "this function is just an alias for method now" #-} + +-- | Guard against the method. Note, this function also guards against +-- any remaining path segments. Similar to 'methodM' but with a different type signature. +-- +-- Example: +-- +-- > handler :: ServerPart Response +-- > handler = methodSP [GET, HEAD] $ subHandler +-- +-- NOTE: This style of combinator is going to be deprecated in the +-- future. It is better to just use 'method'. +-- +-- > handler :: ServerPart Response +-- > handler = method [GET, HEAD] >> nullDir >> subHandler +{-# DEPRECATED methodSP "use method instead." #-} +methodSP :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m b-> m b +methodSP m handle = methodM m >> handle + +-- | guard which only succeeds if there are no remaining path segments +-- +-- Often used if you want to explicitly assign a route for '/' +-- +nullDir :: (ServerMonad m, MonadPlus m) => m () +nullDir = guardRq $ \rq -> null (rqPaths rq) + +-- | Pop a path element and run the supplied handler if it matches the +-- given string. +-- +-- > handler :: ServerPart Response +-- > handler = dir "foo" $ dir "bar" $ subHandler +-- +-- The path element can not contain \'/\'. See also 'dirs'. +dir :: (ServerMonad m, MonadPlus m) => String -> m a -> m a +dir staticPath handle = + do + rq <- askRq + case rqPaths rq of + (p:xs) | p == staticPath -> localRq (\newRq -> newRq{rqPaths = xs}) handle + _ -> mzero + +-- | Guard against a 'FilePath'. Unlike 'dir' the 'FilePath' may +-- contain \'/\'. If the guard succeeds, the matched elements will be +-- popped from the directory stack. +-- +-- > dirs "foo/bar" $ ... +-- +-- See also: 'dir'. +dirs :: (ServerMonad m, MonadPlus m) => FilePath -> m a -> m a +dirs fp m = + do let parts = splitDirectories (makeRelative "/" fp) + foldr dir m parts + +-- | Guard against the host. +-- +-- This matches against the @host@ header specified in the incoming 'Request'. +-- +-- Can be used to support virtual hosting, +-- +-- Note that this matches against the value of the @Host@ header which may include the port number. +-- +-- +-- +-- see also: 'withHost' +host :: (ServerMonad m, MonadPlus m) => String -> m a -> m a +host desiredHost handle = + do rq <- askRq + case getHeader "host" rq of + (Just hostBS) | desiredHost == B.unpack hostBS -> handle + _ -> mzero + +-- | Lookup the @host@ header in the incoming request and pass it to the handler. +-- +-- see also: 'host' +withHost :: (ServerMonad m, MonadPlus m) => (String -> m a) -> m a +withHost handle = + do rq <- askRq + case getHeader "host" rq of + (Just hostBS) -> handle (B.unpack hostBS) + _ -> mzero + + +-- | Pop a path element and parse it using the 'fromReqURI' in the +-- 'FromReqURI' class. +path :: (FromReqURI a, MonadPlus m, ServerMonad m) => (a -> m b) -> m b +path handle = do + rq <- askRq + case rqPaths rq of + (p:xs) | Just a <- fromReqURI p + -> localRq (\newRq -> newRq{rqPaths = xs}) (handle a) + _ -> mzero + +-- | Grab the rest of the URL (dirs + query) and passes it to your +-- handler. +uriRest :: (ServerMonad m) => (String -> m a) -> m a +uriRest handle = askRq >>= handle . rqURL + +-- | Pop any path element and run the handler. +-- +-- Succeeds if a path component was popped. Fails is the remaining path was empty. +anyPath :: (ServerMonad m, MonadPlus m) => m r -> m r +anyPath x = path $ (\(_::String) -> x) + +-- | Guard which checks that the Request URI ends in @\'\/\'@. Useful +-- for distinguishing between @foo@ and @foo/@ +trailingSlash :: (ServerMonad m, MonadPlus m) => m () +trailingSlash = guardRq $ \rq -> (last (rqUri rq)) == '/' + +-- | The opposite of 'trailingSlash'. +noTrailingSlash :: (ServerMonad m, MonadPlus m) => m () +noTrailingSlash = guardRq $ \rq -> (last (rqUri rq)) /= '/' diff --git a/src/Happstack/Server/RqData.hs b/src/Happstack/Server/RqData.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/RqData.hs @@ -0,0 +1,720 @@ +{-# 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 + look + , looks + , lookText + , lookText' + , lookTexts + , lookTexts' + , lookBS + , lookBSs + , lookRead + , lookReads + , lookFile + , lookPairs + , lookPairsBS + -- ** Cookies + , lookCookie + , lookCookieValue + , readCookieValue + -- ** low-level + , lookInput + , lookInputs + -- * Filters + -- The look* functions normally search the QUERY_STRING and the Request + -- body for matches keys. + , body + , queryString + , bytestring + -- * Validation and Parsing + , checkRq + , checkRqM + , readRq + , unsafeReadRq + -- * Handling POST\/PUT Requests + , decodeBody + -- ** Body Policy + , BodyPolicy(..) + , defaultBodyPolicy + -- * RqData Monad & Error Reporting + , RqData + , mapRqData + , Errors(..) + -- ** Using RqData with ServerMonad + , getDataFn + , withDataFn + , FromData(..) + , getData + , withData + -- * HasRqData class + , RqEnv + , HasRqData(askRqEnv, localRqEnv,rqDataError) + ) where + +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) +import qualified Control.Monad.Writer.Lazy as Lazy (WriterT, mapWriterT) +import qualified Control.Monad.Writer.Strict as Strict (WriterT, mapWriterT) +import qualified Control.Monad.RWS.Lazy as Lazy (RWST, mapRWST) +import qualified Control.Monad.RWS.Strict as Strict (RWST, mapRWST) +#if !MIN_VERSION_transformers(0,6,0) +import qualified Control.Monad.Trans.Error as DeprecatedError +#endif +import Control.Monad.Except (throwError) +import Control.Monad.Trans (MonadIO(..), lift) +import Control.Monad.Trans.Except (ExceptT, mapExceptT) +import qualified Data.ByteString.Char8 as P +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.ByteString.Lazy.UTF8 as LU +import Data.Char (toLower) +import Data.Either (partitionEithers) +import Data.Generics (Data) +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 +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) + +#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) + +#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) + +#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) + +apEither :: (Monoid e) => Either e (a -> b) -> Either e a -> Either e b +apEither (Left errs1) (Left errs2) = Left (errs1 `mappend` errs2) +apEither (Left errs) _ = Left errs +apEither _ (Left errs) = Left errs +apEither (Right f) (Right a) = Right (f a) + +-- | a list of errors +newtype Errors a = Errors { unErrors :: [a] } + 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 [] + mappend = (SG.<>) + mconcat errs = Errors $ concatMap unErrors errs + +#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 ()) + +mapReaderErrorT :: (Either e a -> Either e' b) -> (ReaderError r e a) -> (ReaderError r e' b) +mapReaderErrorT f m = ReaderError $ mapReaderT f (unReaderError m) +-} + +runReaderError :: ReaderError r e a -> r -> Either e a +runReaderError = runReaderT . unReaderError + +-- | the environment used to lookup query parameters. It consists of +-- the triple: (query string inputs, body inputs, cookie inputs) +type RqEnv = ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)]) + +-- | An applicative functor and monad for looking up key/value pairs +-- in the QUERY_STRING, Request body, and cookies. +newtype RqData a = RqData { unRqData :: ReaderError RqEnv (Errors String) a } + deriving (Functor, Monad, MonadPlus, Applicative, Alternative, MonadReader RqEnv ) + +-- | A class for monads which contain a 'RqEnv' +class HasRqData m where + askRqEnv :: m RqEnv + localRqEnv :: (RqEnv -> RqEnv) -> m a -> m a + -- | lift some 'Errors' into 'RqData' + rqDataError :: Errors String -> m a + +instance HasRqData RqData where + askRqEnv = RqData ask + localRqEnv f (RqData re) = RqData $ local f re + rqDataError e = mapRqData ((Left e) `apEither`) (return ()) + +-- instance (MonadPlus m, MonadIO m, ServerMonad m) => (HasRqData m) where +instance (MonadIO m, MonadPlus m) => HasRqData (ServerPartT m) where + askRqEnv = smAskRqEnv + rqDataError _e = mzero + localRqEnv = smLocalRqEnv + +------------------------------------------------------------------------------ +-- HasRqData instances for ReaderT, StateT, WriterT, RWST, and ErrorT +------------------------------------------------------------------------------ + +instance (Monad m, HasRqData m) => HasRqData (ReaderT s m) where + askRqEnv = lift askRqEnv + localRqEnv f = mapReaderT (localRqEnv f) + rqDataError e = lift (rqDataError e) + +instance (Monad m, HasRqData m) => HasRqData (Lazy.StateT s m) where + askRqEnv = lift askRqEnv + localRqEnv f = Lazy.mapStateT (localRqEnv f) + rqDataError e = lift (rqDataError e) + +instance (Monad m, HasRqData m) => HasRqData (Strict.StateT s m) where + askRqEnv = lift askRqEnv + localRqEnv f = Strict.mapStateT (localRqEnv f) + rqDataError e = lift (rqDataError e) + +instance (Monad m, HasRqData m, Monoid w) => HasRqData (Lazy.WriterT w m) where + askRqEnv = lift askRqEnv + localRqEnv f = Lazy.mapWriterT (localRqEnv f) + rqDataError e = lift (rqDataError e) + +instance (Monad m, HasRqData m, Monoid w) => HasRqData (Strict.WriterT w m) where + askRqEnv = lift askRqEnv + localRqEnv f = Strict.mapWriterT (localRqEnv f) + rqDataError e = lift (rqDataError e) + +instance (Monad m, HasRqData m, Monoid w) => HasRqData (Lazy.RWST r w s m) where + askRqEnv = lift askRqEnv + localRqEnv f = Lazy.mapRWST (localRqEnv f) + rqDataError e = lift (rqDataError e) + +instance (Monad m, HasRqData m, Monoid w) => HasRqData (Strict.RWST r w s m) where + askRqEnv = lift askRqEnv + localRqEnv f = Strict.mapRWST (localRqEnv f) + rqDataError e = lift (rqDataError e) + +#if !MIN_VERSION_transformers(0,6,0) +instance (Monad m, DeprecatedError.Error e, HasRqData m) => HasRqData (DeprecatedError.ErrorT e m) where + askRqEnv = lift askRqEnv + localRqEnv f = DeprecatedError.mapErrorT (localRqEnv f) + rqDataError e = lift (rqDataError e) +#endif + +instance (Monad m, HasRqData m) => HasRqData (ExceptT e m) where + askRqEnv = lift askRqEnv + localRqEnv f = mapExceptT (localRqEnv f) + rqDataError e = lift (rqDataError e) + +-- | apply 'RqData a' to a 'RqEnv' +-- +-- see also: 'getData', 'getDataFn', 'withData', 'withDataFn', 'RqData', 'getDataFn' +runRqData :: RqData a -> RqEnv -> Either [String] a +runRqData rqData rqEnv = + either (Left . unErrors) Right $ runReaderError (unRqData rqData) rqEnv + +-- | transform the result of 'RqData a'. +-- +-- This is similar to 'fmap' except it also allows you to modify the +-- 'Errors' not just 'a'. +mapRqData :: (Either (Errors String) a -> Either (Errors String) b) -> RqData a -> RqData b +mapRqData f m = RqData $ ReaderError $ mapReaderT f (unReaderError (unRqData m)) + +-- | use 'read' to convert a 'String' to a value of type 'a' +-- +-- > look "key" `checkRq` (unsafeReadRq "key") +-- +-- use with 'checkRq' +-- +-- NOTE: This function is marked unsafe because some Read instances +-- are vulnerable to attacks that attempt to create an out of memory +-- condition. For example: +-- +-- > read "1e10000000000000" :: Integer +-- +-- see also: 'readRq' +unsafeReadRq :: (Read a) => + String -- ^ name of key (only used for error reporting) + -> String -- ^ 'String' to 'read' + -> Either String a -- ^ 'Left' on error, 'Right' on success +unsafeReadRq key val = + case reads val of + [(a,[])] -> Right a + _ -> Left $ "readRq failed while parsing key: " ++ key ++ " which has the value: " ++ val + +-- | use 'fromReqURI' to convert a 'String' to a value of type 'a' +-- +-- > look "key" `checkRq` (readRq "key") +-- +-- use with 'checkRq' +readRq :: (FromReqURI a) => + String -- ^ name of key (only used for error reporting) + -> String -- ^ 'String' to 'read' + -> Either String a -- ^ 'Left' on error, 'Right' on success +readRq key val = + case fromReqURI val of + (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 +-- returning Left and an error message. The error will be propagated +-- by calling 'rqDataError'. +-- +-- This function is useful for a number of things including: +-- +-- (1) Parsing a 'String' into another type +-- +-- (2) Checking that a value meets some requirements (for example, that is an Int between 1 and 10). +-- +-- Example usage at: +-- +-- +checkRq :: (Monad m, HasRqData m) => m a -> (a -> Either String b) -> m b +checkRq rq f = + do a <- rq + case f a of + (Left e) -> rqDataError (strMsg e) + (Right b) -> return b + +-- | like 'checkRq' but the check function can be monadic +checkRqM :: (Monad m, HasRqData m) => m a -> (a -> m (Either String b)) -> m b +checkRqM rq f = + do a <- rq + eb <- f a + case eb of + (Left e) -> rqDataError (strMsg e) + (Right b) -> return b + +-- | Used by 'withData' and 'getData'. Make your preferred data +-- type an instance of 'FromData' to use those functions. +class FromData a where + fromData :: RqData a +{- +instance (Eq a,Show a,Xml a,G.Data a) => FromData a where + fromData = do mbA <- lookPairs >>= return . normalize . fromPairs + case mbA of + Just a -> return a + Nothing -> fail "FromData G.Data failure" +-- fromData = lookPairs >>= return . normalize . fromPairs +-} +instance (FromData a, FromData b) => FromData (a,b) where + fromData = (,) <$> fromData <*> fromData + +instance (FromData a, FromData b, FromData c) => FromData (a,b,c) where + fromData = (,,) <$> fromData <*> fromData <*> fromData + +instance (FromData a, FromData b, FromData c, FromData d) => FromData (a,b,c,d) where + fromData = (,,,) <$> fromData <*> fromData <*> fromData <*> fromData + +instance FromData a => FromData (Maybe a) where + fromData = (Just <$> fromData) <|> (pure Nothing) + +-- | similar to 'Data.List.lookup' but returns all matches not just the first +lookups :: (Eq a) => a -> [(a, b)] -> [b] +lookups a = map snd . filter ((a ==) . fst) + +fromMaybeBody :: String -> String -> Maybe [(String, Input)] -> [(String, Input)] +fromMaybeBody funName fieldName mBody = + case mBody of + Nothing -> error $ funName ++ " " ++ fieldName ++ " failed because the request body has not been decoded yet. Try using 'decodeBody' to decode the body. Or the 'queryString' filter to ignore the body." + (Just bdy) -> bdy + +-- | Gets the first matching named input parameter +-- +-- Searches the QUERY_STRING followed by the Request body. +-- +-- see also: 'lookInputs' +lookInput :: (Monad m, HasRqData m) => String -> m Input +lookInput name + = do (query, mBody, _cookies) <- askRqEnv + let bdy = fromMaybeBody "lookInput" name mBody + case lookup name (query ++ bdy) of + Just i -> return $ i + Nothing -> rqDataError (strMsg $ "Parameter not found: " ++ name) + +-- | Gets all matches for the named input parameter +-- +-- Searches the QUERY_STRING followed by the Request body. +-- +-- see also: 'lookInput' +lookInputs :: (Monad m, HasRqData m) => String -> m [Input] +lookInputs name + = do (query, mBody, _cookies) <- askRqEnv + let bdy = fromMaybeBody "lookInputs" name mBody + return $ lookups name (query ++ bdy) + +-- | Gets the first matching named input parameter as a lazy 'ByteString' +-- +-- Searches the QUERY_STRING followed by the Request body. +-- +-- see also: 'lookBSs' +lookBS :: (Functor m, Monad m, HasRqData m) => String -> m L.ByteString +lookBS n = + do i <- fmap inputValue (lookInput n) + case i of + (Left _fp) -> rqDataError $ (strMsg $ "lookBS: " ++ n ++ " is a file.") + (Right bs) -> return bs + +-- | Gets all matches for the named input parameter as lazy 'ByteString's +-- +-- Searches the QUERY_STRING followed by the Request body. +-- +-- see also: 'lookBS' +lookBSs :: (Functor m, Monad m, HasRqData m) => String -> m [L.ByteString] +lookBSs n = + do is <- fmap (map inputValue) (lookInputs n) + case partitionEithers is of + ([], bs) -> return bs + (_fp, _) -> rqDataError (strMsg $ "lookBSs: " ++ n ++ " is a file.") + +-- | Gets the first matching named input parameter as a 'String' +-- +-- Searches the QUERY_STRING followed by the Request body. +-- +-- This function assumes the underlying octets are UTF-8 encoded. +-- +-- Example: +-- +-- > handler :: ServerPart Response +-- > handler = +-- > do foo <- look "foo" +-- > ok $ toResponse $ "foo = " ++ foo +-- +-- see also: 'looks', 'lookBS', and 'lookBSs' +look :: (Functor m, Monad m, HasRqData m) => String -> m String +look = fmap LU.toString . lookBS + +-- | Gets all matches for the named input parameter as 'String's +-- +-- Searches the QUERY_STRING followed by the Request body. +-- +-- This function assumes the underlying octets are UTF-8 encoded. +-- +-- see also: 'look' and 'lookBSs' +looks :: (Functor m, Monad m, HasRqData m) => String -> m [String] +looks = fmap (map LU.toString) . lookBSs + +-- | Gets the first matching named input parameter as a lazy 'Text' +-- +-- Searches the QUERY_STRING followed by the Request body. +-- +-- This function assumes the underlying octets are UTF-8 encoded. +-- +-- see also: 'lookTexts', 'look', 'looks', 'lookBS', and 'lookBSs' +lookText :: (Functor m, Monad m, HasRqData m) => String -> m LazyText.Text +lookText = fmap LazyText.decodeUtf8 . lookBS + +-- | Gets the first matching named input parameter as a strict 'Text' +-- +-- Searches the QUERY_STRING followed by the Request body. +-- +-- This function assumes the underlying octets are UTF-8 encoded. +-- +-- see also: 'lookTexts', 'look', 'looks', 'lookBS', and 'lookBSs' +lookText' :: (Functor m, Monad m, HasRqData m) => String -> m Text +lookText' = fmap LazyText.toStrict . lookText + +-- | Gets all matches for the named input parameter as lazy 'Text's +-- +-- Searches the QUERY_STRING followed by the Request body. +-- +-- This function assumes the underlying octets are UTF-8 encoded. +-- +-- see also: 'lookText', 'looks' and 'lookBSs' +lookTexts :: (Functor m, Monad m, HasRqData m) => String -> m [LazyText.Text] +lookTexts = fmap (map LazyText.decodeUtf8) . lookBSs + +-- | Gets all matches for the named input parameter as strict 'Text's +-- +-- Searches the QUERY_STRING followed by the Request body. +-- +-- This function assumes the underlying octets are UTF-8 encoded. +-- +-- see also: 'lookText'', 'looks' and 'lookBSs' +lookTexts' :: (Functor m, Monad m, HasRqData m) => String -> m [Text] +lookTexts' = fmap (map LazyText.toStrict) . lookTexts + +-- | Gets the named cookie +-- the cookie name is case insensitive +lookCookie :: (Monad m, HasRqData m) => String -> m Cookie +lookCookie name + = 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{cookieValue = f c} + where + f = unEscapeString . cookieValue + +-- | gets the named cookie as a string +lookCookieValue :: (Functor m, Monad m, HasRqData m) => String -> m String +lookCookieValue = fmap cookieValue . lookCookie + +-- | gets the named cookie as the requested Read type +readCookieValue :: (Functor m, Monad m, HasRqData m, FromReqURI a) => String -> m a +readCookieValue name = fmap cookieValue (lookCookie name) `checkRq` (readRq name) + +-- | Gets the first matching named input parameter and decodes it using 'Read' +-- +-- Searches the QUERY_STRING followed by the Request body. +-- +-- This function assumes the underlying octets are UTF-8 encoded. +-- +-- see also: 'lookReads' +lookRead :: (Functor m, Monad m, HasRqData m, FromReqURI a) => String -> m a +lookRead name = look name `checkRq` (readRq name) + +-- | Gets all matches for the named input parameter and decodes them using 'Read' +-- +-- Searches the QUERY_STRING followed by the Request body. +-- +-- This function assumes the underlying octets are UTF-8 encoded. +-- +-- see also: 'lookReads' +lookReads :: (Functor m, Monad m, HasRqData m, FromReqURI a) => String -> m [a] +lookReads name = + do vals <- looks name + mapM (\v -> (return v) `checkRq` (readRq name)) vals + +-- | Gets the first matching named file +-- +-- Files can only appear in the request body. Additionally, the form +-- must set enctype=\"multipart\/form-data\". +-- +-- This function returns a tuple consisting of: +-- +-- (1) The temporary location of the uploaded file +-- +-- (2) The local filename supplied by the browser +-- +-- (3) The content-type supplied by the browser +-- +-- If the user does not supply a file in the html form input field, +-- the behaviour will depend upon the browser. Most browsers will send +-- a 0-length file with an empty file name, so checking that (2) is +-- not empty is usually sufficient to ensure the field has been +-- filled. +-- +-- NOTE: You must move the file from the temporary location before the +-- 'Response' is sent. The temporary files are automatically removed +-- after the 'Response' is sent. +lookFile :: (Monad m, HasRqData m) => + String -- ^ name of input field to search for + -> m (FilePath, FilePath, ContentType) -- ^ (temporary file location, uploaded file name, content-type) +lookFile n = + do i <- lookInput n + case inputValue i of + (Right _) -> rqDataError $ (strMsg $ "lookFile: " ++ n ++ " was found but is not a file.") + (Left fp) -> return (fp, fromJust $ inputFilename i, inputContentType i) + +-- | gets all the input parameters, and converts them to a 'String' +-- +-- The results will contain the QUERY_STRING followed by the Request +-- body. +-- +-- This function assumes the underlying octets are UTF-8 encoded. +-- +-- see also: 'lookPairsBS' +lookPairs :: (Monad m, HasRqData m) => m [(String, Either FilePath String)] +lookPairs = + do (query, mBody, _cookies) <- askRqEnv + let bdy = fromMaybeBody "lookPairs" "" mBody + return $ map (\(n,vbs)->(n, (\e -> case e of Left fp -> Left fp ; Right bs -> Right (LU.toString bs)) $ inputValue vbs)) (query ++ bdy) + +-- | gets all the input parameters +-- +-- The results will contain the QUERY_STRING followed by the Request +-- body. +-- +-- see also: 'lookPairs' +lookPairsBS :: (Monad m, HasRqData m) => m [(String, Either FilePath L.ByteString)] +lookPairsBS = + do (query, mBody, _cookies) <- askRqEnv + let bdy = fromMaybeBody "lookPairsBS" "" mBody + return $ map (\(n,vbs) -> (n, inputValue vbs)) (query ++ bdy) + +-- | 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 +-- 'Request' with out first calling this function. +-- +-- It is ok to call 'decodeBody' at the beginning of every request: +-- +-- > main = simpleHTTP nullConf $ +-- > do decodeBody (defaultBodyPolicy "/tmp/" 4096 4096 4096) +-- > handlers +-- +-- You can achieve finer granularity quotas by calling 'decodeBody' +-- with different values in different handlers. +-- +-- Only the first call to 'decodeBody' will have any effect. Calling +-- it a second time, even with different quota values, will do +-- nothing. +decodeBody :: (ServerMonad m, MonadPlus m, MonadIO m, FilterMonad Response m, WebMonad Response m) => BodyPolicy -> m () +decodeBody bp = + do rq <- askRq + (_, me) <- bodyInput bp rq + case me of + Nothing -> return () + Just e -> escape $ requestEntityTooLarge (toResponse e) -- FIXME: is this the best way to report the error + +-- | run 'RqData' in a 'ServerMonad'. +-- +-- Example: a simple @GET@ or @POST@ variable based authentication +-- guard. It handles the request with 'errorHandler' if +-- authentication fails. +-- +-- > data AuthCredentials = AuthCredentials { username :: String, password :: String } +-- > +-- > isValid :: AuthCredentials -> Bool +-- > isValid = const True +-- > +-- > myRqData :: RqData AuthCredentials +-- > myRqData = do +-- > username <- look "username" +-- > password <- look "password" +-- > return (AuthCredentials username password) +-- > +-- > checkAuth :: (String -> ServerPart Response) -> ServerPart Response +-- > checkAuth errorHandler = do +-- > d <- getDataFn myRqData +-- > case d of +-- > (Left e) -> errorHandler (unlines e) +-- > (Right a) | isValid a -> mzero +-- > (Right a) | otherwise -> errorHandler "invalid" +-- +-- NOTE: you must call 'decodeBody' prior to calling this function if +-- 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 +getDataFn rqData = + do rqEnv <- askRqEnv + return (runRqData rqData rqEnv) + +-- | similar to 'getDataFn', except it calls a sub-handler on success +-- or 'mzero' on failure. +-- +-- NOTE: you must call 'decodeBody' prior to calling this function if +-- the request method is POST, PUT, PATCH, etc. +withDataFn :: (HasRqData m, MonadPlus m, ServerMonad m) => RqData a -> (a -> m r) -> m r +withDataFn fn handle = getDataFn fn >>= either (const mzero) handle + +-- | A variant of 'getDataFn' that uses 'FromData' to chose your +-- 'RqData' for you. The example from 'getData' becomes: +-- +-- > data AuthCredentials = AuthCredentials { username :: String, password :: String } +-- > +-- > isValid :: AuthCredentials -> Bool +-- > isValid = const True +-- > +-- > myRqData :: RqData AuthCredentials +-- > myRqData = do +-- > username <- look "username" +-- > password <- look "password" +-- > return (AuthCredentials username password) +-- > +-- > instance FromData AuthCredentials where +-- > fromData = myRqData +-- > +-- > checkAuth :: (String -> ServerPart Response) -> ServerPart Response +-- > checkAuth errorHandler = do +-- > d <- getData +-- > case d of +-- > (Left e) -> errorHandler (unlines e) +-- > (Right a) | isValid a -> mzero +-- > (Right a) | otherwise -> errorHandler "invalid" +-- +-- NOTE: you must call 'decodeBody' prior to calling this function if +-- 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, PUT, PATCH, etc. +withData :: (HasRqData m, FromData a, MonadPlus m, ServerMonad m) => (a -> m r) -> m r +withData = withDataFn fromData + +-- | limit the scope to the Request body +-- +-- > handler :: ServerPart Response +-- > handler = +-- > do foo <- body $ look "foo" +-- > ok $ toResponse $ "foo = " ++ foo +body :: (HasRqData m) => m a -> m a +body rqData = localRqEnv f rqData + where + f (_query, bdy, _cookies) = ([], bdy, []) + +-- | limit the scope to the QUERY_STRING +-- +-- > handler :: ServerPart Response +-- > handler = +-- > do foo <- queryString $ look "foo" +-- > ok $ toResponse $ "foo = " ++ foo +queryString :: (HasRqData m) => m a -> m a +queryString rqData = localRqEnv f rqData + where + f (query, _body, _cookies) = (query, Just [], []) + +-- | limit the scope to 'Input's which produce a 'ByteString' (aka, not a file) +bytestring :: (HasRqData m) => m a -> m a +bytestring rqData = localRqEnv f rqData + where + f (query, bdy, cookies) = (filter bsf query, filter bsf <$> bdy, cookies) + bsf (_, i) = + case inputValue i of + (Left _fp) -> False + (Right _bs) -> True diff --git a/src/Happstack/Server/S3.hs b/src/Happstack/Server/S3.hs deleted file mode 100644 --- a/src/Happstack/Server/S3.hs +++ /dev/null @@ -1,240 +0,0 @@ -{-# LANGUAGE PatternGuards #-} -module Happstack.Server.S3 - ( newS3 -- :: AccessKey -> SecretKey -> URI -> IO S3 - , closeS3 -- :: S3 -> IO () - , createBucket -- :: S3 -> BucketId -> IO () - , createObject -- :: S3 -> BucketId -> ObjectId -> String -> IO () - , getObject -- :: S3 -> BucketId -> ObjectId -> IO String - , deleteBucket -- :: S3 -> BucketId -> IO () - , deleteObject -- :: S3 -> BucketId -> ObjectId -> IO () - , listObjects -- :: S3 -> BucketId -> IO [String] - , sendRequest -- :: S3 -> Request -> IO String - , sendRequest_ -- :: S3 -> Request -> IO () --- , sendRequests -- :: S3 -> [Request] -> IO () - , BucketId, ObjectId, AccessKey, SecretKey - , amazonURI - ) where - -import Happstack.Crypto.HMAC ( hmacSHA1 ) -import Happstack.Server.HTTPClient.HTTP -import qualified Happstack.Server.HTTPClient.Stream as Stream - -import Network.URI hiding (path) -import Control.Concurrent ( newMVar, modifyMVar, swapMVar - , modifyMVar_, MVar ) -import Data.Maybe ( fromJust, fromMaybe ) -import Data.List ( intersperse ) -import System.Time ( getClockTime, toCalendarTime - , formatCalendarTime ) -import System.Locale ( defaultTimeLocale, rfc822DateFormat ) - -import Text.XML.HaXml ( xmlParse, Document(..), Content(..) ) -import Text.XML.HaXml.Xtract.Parse ( xtract ) - -type BucketId = String -type ObjectId = String -type AccessKey = String -type SecretKey = String - -data S3 - = S3 - { s3AccessKey :: AccessKey - , s3SecretKey :: SecretKey - , s3URI :: URI --- , s3KeepAliveTimeout :: Int - , s3Conn :: MVar (Maybe Connection) - } - -{- | - Sign a request using the access key and secret key from the S3 data - type. --} -signRequest :: S3 -> Request -> IO Request -signRequest s3 - = let akey = s3AccessKey s3 - skey = s3SecretKey s3 - in signRequest' akey skey - -{- | - Fill in necessary information (such as a date header) and then sign - then request. --} -signRequest' :: AccessKey -> SecretKey -> Request -> IO Request -signRequest' akey skey request - = do now <- getClockTime - cal <- toCalendarTime now - let isoDate = formatCalendarTime defaultTimeLocale rfc822DateFormat cal - auth = fromJust (uriAuthority (rqURI request)) --- authErr = error "S3.hs: internal error: failed to parse authority" - let dat = concat $ intersperse "\n" - [show (rqMethod request) - ,lookupHeader HdrContentMD5 - ,lookupHeader HdrContentType - ,isoDate - ,uriPath (rqURI request)] - authorization = Header HdrAuthorization $ "AWS " ++ akey ++ ":" ++ signature - signature = hmacSHA1 skey dat - lookupHeader hn = fromMaybe "" (findHeader hn request) - dateHdr = Header HdrDate isoDate - lengthHdr = Header HdrContentLength (show $ length (rqBody request)) - connHdr = Header HdrConnection "Keep-Alive" - hostHdr = Header HdrHost (uriRegName auth) - return $ request - { rqHeaders = hostHdr:connHdr:lengthHdr:dateHdr: - authorization:rqHeaders request - , rqURI = (rqURI request) { uriScheme = "" - , uriAuthority = Nothing}} - -{- | - Return a connection to an S3 server. Will initiate a new - connection if no previous was found. --} -getConnection :: S3 -> IO Connection -getConnection s3 - = modifyMVar (s3Conn s3) $ \mbConn -> - case mbConn of - Just conn -> return (mbConn,conn) - Nothing -> do print (uriRegName auth, uriPort auth) - c <- openTCPPort (uriRegName auth) (if null $ uriPort auth then 80 else read$ uriPort auth) - return (Just c,c) - where auth = fromJust (uriAuthority (s3URI s3)) - -createRequest :: S3 -> RequestMethod -> String -> String -> Request -createRequest _s3 method path body - = Request uri method [] body - where uri = localhost { uriPath = '/':escapeURIString isAllowedInURI path } - -{- | - Send a single request to an S3 server returning the body - of the result. --} -sendRequest :: S3 -> Request -> IO String -sendRequest s3 request - = loop =<< signRequest s3 request - where loop request' - = do c <- getConnection s3 - ret <- sendHTTP c request' - case ret of - Left ErrorClosed - -> do putStrLn "Connection closed." - swapMVar (s3Conn s3) Nothing - loop request' - Left err -> error ("Failed to connect: " ++ show err) -- FIXME - Right res - | (2,_,_) <- rspCode res -> return (rspBody res) - | otherwise -> error ("Server error: " ++ rspReason res) - -{- | - Same as 'sendRequest' except that it ignored the result. --} -sendRequest_ :: S3 -> Request -> IO () -sendRequest_ s3 request - = do sendRequest s3 request - return () - -{- - Sign and send requests pipelined over a keep-alive connection. --} -{- - S3 imposes a quite severe limitation on pipelined requests. - Sending too many requests or exceeding a size limit will - result in a disconnect. The precise borders of these limits - are hard-wired and unknown to the general public. At the time - of this writing, sending three requests at a time seems optimal. - - Quote from Amazons web-forum: - (http://developer.amazonwebservices.com/connect/thread.jspa?messageID=39883) - "OK, we have located the cause of the behavior you are seeing. - Your pipelined requests are being aborted because one of the - network devices handling the connection has certain limitations - on the amount of pipelined data it is willing to accept per - connection, and that limit is being exceeded. Unfortunately, this - limit is phrased in very low-level terms so it isn't possible to - say in a platform or network independent way whether any given - size, sequence or number of requests will exceed the limit and - cause a disconnection or not. We have engaged with the device - vendor and found out that this limit is hard-wired and that this - behavior is not likely to change any time soon. - - In light of these facts, here is some guidance on pipelining HTTP - requests to Amazon S3. - 1) Be optimistic and pipeline a modest number of GET or HEAD - requests, say two to four. - 2) Handle asynchronous disconnects by re-connecting and re-sending - unacknowledged requests left in your pipeline. (As Colin points - out, correct HTTP clients must do this anyway) - 3) If possible, try to minimize the number of TCP segments your - pipelined requests generate. In particular, leave the TCP socket - no delay option off and send as many requests per socket write call - as is practical." --} - --------------------------------------------------------------- --- Initiate --------------------------------------------------------------- - -newS3 :: AccessKey -> SecretKey -> URI -> IO S3 -newS3 akey skey uri - = do conn <- newMVar Nothing - return $ S3 { s3AccessKey = akey - , s3SecretKey = skey - , s3URI = uri --- , s3KeepAliveTimeout :: Int - , s3Conn = conn - } - -closeS3 :: S3 -> IO () -closeS3 s3 - = modifyMVar_ (s3Conn s3) $ \mbConn -> - case mbConn of - Nothing -> return Nothing - Just conn -> do Stream.close conn - return Nothing - - --------------------------------------------------------------- --- Requests --------------------------------------------------------------- - - -createBucket :: S3 -> BucketId -> Request -createBucket s3 bucket - = createRequest s3 PUT bucket "" - -createObject :: S3 -> BucketId -> ObjectId -> String -> Request -createObject s3 bucket object - = createRequest s3 PUT (bucket ++ "/" ++ object) - -getObject :: S3 -> BucketId -> ObjectId -> Request -getObject s3 bucket object - = createRequest s3 GET (bucket ++ "/" ++ object) "" - -deleteBucket :: S3 -> BucketId -> Request -deleteBucket s3 bucket - = createRequest s3 DELETE bucket "" - -deleteObject :: S3 -> BucketId -> ObjectId -> Request -deleteObject s3 bucket object - = createRequest s3 DELETE (bucket ++ "/" ++ object) "" - --------------------------------------------------------------- --- Actions --------------------------------------------------------------- - - -listObjects :: S3 -> BucketId -> IO [String] -listObjects s3 bucket - = do lst <- sendRequest s3 (createRequest s3 GET bucket "") - return $ ppContent . auxFilter . getContent . xmlParse bucket $ lst - where auxFilter = xtract "*/Key/-" - getContent (Document _ _ e _) = CElem e - - ppContent xs = [ s | CString _ s <- xs ] - - - -amazonURI :: URI -amazonURI = fromJust $ parseURI "http://s3.amazonaws.com/" -localhost :: URI -localhost = fromJust $ parseURI "http://localhost/" - diff --git a/src/Happstack/Server/SURI.hs b/src/Happstack/Server/SURI.hs --- a/src/Happstack/Server/SURI.hs +++ b/src/Happstack/Server/SURI.hs @@ -1,10 +1,32 @@ -{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances #-} +-- | A wrapper and type class so that functions like 'seeOther' can take a URI which is represented by a 'String', 'URI.URI', or other instance of 'ToSURI'. +module Happstack.Server.SURI + ( path + , query + , scheme + , u_scheme + , u_path + , a_scheme + , a_path + , percentDecode + , unEscape + , unEscapeQS + , isAbs + , SURI(..) + , render + , parse + , ToSURI(..) + , FromPath(..) + ) + where -module Happstack.Server.SURI where -import Data.Maybe -import Data.Generics -import Happstack.Util.Common(mapFst) -import qualified Network.URI as URI +import Control.Arrow (first) +import Data.Char (chr, digitToInt, isHexDigit) +import Data.Maybe (fromJust, isJust) +import Data.Generics (Data) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import qualified Network.URI as URI -- | Retrieves the path component from the URI path :: SURI -> String @@ -34,19 +56,32 @@ a_path :: String -> SURI -> SURI a_path a (SURI u) = SURI $ u {URI.uriPath=a} -escape, unEscape :: String -> String -unEscape = URI.unEscapeString . map (\x->if x=='+' then ' ' else x) -escape = URI.escapeURIString URI.isAllowedInURI +-- | percent decode a String +-- +-- e.g. @\"hello%2Fworld\"@ -> @\"hello/world\"@ +percentDecode :: String -> String +percentDecode [] = "" +percentDecode ('%':x1:x2:s) | isHexDigit x1 && isHexDigit x2 = + chr (digitToInt x1 * 16 + digitToInt x2) : percentDecode s +percentDecode (c:s) = c : percentDecode s +unEscape, unEscapeQS :: String -> String +unEscapeQS = percentDecode . map (\x->if x=='+' then ' ' else x) +unEscape = percentDecode +-- escape = URI.escapeURIString URI.isAllowedInURI + +-- | Returns true if the URI is absolute isAbs :: SURI -> Bool isAbs = not . null . URI.uriScheme . suri ---isAbs = maybe True ( mbParsed -newtype SURI = SURI {suri::URI.URI} deriving (Eq,Data,Typeable) +newtype SURI = SURI {suri::URI.URI} deriving (Eq,Data) instance Show SURI where showsPrec d (SURI uri) = showsPrec d $ show uri instance Read SURI where - readsPrec d = mapFst fromJust . filter (isJust . fst) . mapFst parse . readsPrec d + readsPrec d = mapFst fromJust . filter (isJust . fst) . mapFst parse . readsPrec d + where + mapFst :: (a -> b) -> [(a,x)] -> [(b,x)] + mapFst = map . first instance Ord SURI where compare a b = show a `compare` show b @@ -57,16 +92,17 @@ -- | Parses a URI from a String. Returns Nothing on failure. parse :: String -> Maybe SURI -parse = fmap SURI . URI.parseURIReference +parse = fmap SURI . URI.parseURIReference -- | Convenience class for converting data types to URIs class ToSURI x where toSURI::x->SURI instance ToSURI SURI where toSURI=id instance ToSURI URI.URI where toSURI=SURI -instance ToSURI String where +instance ToSURI String where toSURI = maybe (SURI $ URI.URI "" Nothing "" "" "") id . parse - +instance ToSURI Text.Text where toSURI = toSURI . Text.unpack +instance ToSURI LazyText.Text where toSURI = toSURI . LazyText.unpack --handling obtaining things from URI paths class FromPath x where fromPath::String->x diff --git a/src/Happstack/Server/SURI/ParseURI.hs b/src/Happstack/Server/SURI/ParseURI.hs --- a/src/Happstack/Server/SURI/ParseURI.hs +++ b/src/Happstack/Server/SURI/ParseURI.hs @@ -1,12 +1,13 @@ module Happstack.Server.SURI.ParseURI(parseURIRef) where +import qualified Data.ByteString as BB import qualified Data.ByteString.Internal as BB import qualified Data.ByteString.Unsafe as BB import Data.ByteString.Char8 as BC import Prelude hiding(break,length,null,drop,splitAt) import Network.URI -import Happstack.Util.ByteStringCompat +-- import Happstack.Util.ByteStringCompat parseURIRef :: ByteString -> URI parseURIRef fs = @@ -79,3 +80,22 @@ unsafeIndex :: ByteString -> Int -> Char unsafeIndex s = BB.w2c . BB.unsafeIndex s +-- | Semantically equivalent to break on strings +{-# INLINE breakChar #-} +breakChar :: Char -> ByteString -> (ByteString, ByteString) +breakChar ch = BB.break ((==) x) where x = BB.c2w ch + +-- | 'breakCharEnd' behaves like breakChar, but from the end of the +-- ByteString. +-- +-- > breakCharEnd ('b') (pack "aabbcc") == ("aab","cc") +-- +-- and the following are equivalent: +-- +-- > breakCharEnd 'c' "abcdef" +-- > let (x,y) = break (=='c') (reverse "abcdef") +-- > in (reverse (drop 1 y), reverse x) +-- +{-# INLINE breakCharEnd #-} +breakCharEnd :: Char -> ByteString -> (ByteString, ByteString) +breakCharEnd c p = BB.breakEnd ((==) x) p where x = BB.c2w c 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 @@ -1,1355 +1,235 @@ -{-# LANGUAGE UndecidableInstances, OverlappingInstances, ScopedTypeVariables, FlexibleInstances, TypeSynonymInstances, - MultiParamTypeClasses, PatternGuards, FlexibleContexts, FunctionalDependencies, GeneralizedNewtypeDeriving, PatternSignatures - #-} -{-# OPTIONS -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Happstack.Server.SimpleHTTP --- Copyright : (c) Happstack.com 2009; (c) HAppS Inc 2007 --- License : BSD-like --- --- Maintainer : lemmih@vo.com --- Stability : provisional --- Portability : requires mtl --- --- SimpleHTTP provides a back-end independent API for handling HTTP requests. --- --- By default, the built-in HTTP server will be used. However, other back-ends --- like CGI\/FastCGI can used if so desired. --- --- So the general nature of 'simpleHTTP' is no different than what you'd expect --- from a web application container. First you figure out when function is --- going to process your request, process the request to generate a response, --- then return that response to the client. The web application container is --- started with 'simpleHTTP', which takes a configuration and a --- response-building structure ('ServerPartT' which I'll return too in a --- moment), and picks the first handler that is willing to accept the request, --- passes the request into the handler. A simple "hello world" style HAppS --- simpleHTTP server looks like: --- --- @ --- main = simpleHTTP nullConf $ return \"Hello World!\" --- @ --- --- @simpleHTTP nullConf@ creates a HTTP server on port 8000. --- return \"Hello World!\" creates a serverPartT that just returns that text. --- --- 'ServerPartT' is the basic response builder. As you might expect, it's a --- container for a function that takes a Request and converts it a response --- suitable for sending back to the server. Most of the time though you don't --- even need to worry about that as ServerPartT hides almost all the machinery --- for building your response by exposing a few type classes. --- --- 'ServerPartT' is a pretty rich monad. You can interact with your request, --- your response, do IO, etc. Here is a do block that validates basic --- authentication It takes a realm name as a string, a Map of username to --- password and a server part to run if authentication fails. --- --- @basicAuth'@ acts like a guard, and only produces a response when --- authentication fails. So put it before any ServerPartT you want to demand --- authentication for in any collection of ServerPartTs. --- --- @ --- --- main = simpleHTTP nullConf $ myAuth, return \"Hello World!\" --- where --- myAuth = basicAuth\' \"Test\" --- (M.fromList [(\"hello\", \"world\")]) (return \"Login Failed\") --- --- basicAuth\' realmName authMap unauthorizedPart = --- do --- let validLogin name pass = M.lookup name authMap == Just pass --- let parseHeader = break (\':\'==) . Base64.decode . B.unpack . B.drop 6 --- authHeader <- getHeaderM \"authorization\" --- case authHeader of --- Nothing -> err --- Just x -> case parseHeader x of --- (name, \':\':pass) | validLogin name pass -> mzero --- | otherwise -> err --- _ -> err --- where --- err = do --- unauthorized () --- setHeaderM headerName headerValue --- unauthorizedPart --- headerValue = \"Basic realm=\\\"\" ++ realmName ++ \"\\\"\" --- headerName = \"WWW-Authenticate\" --- @ --- --- Here is another example that uses liftIO to embed IO in a request process --- --- @ --- main = simpleHTTP nullConf $ myPart --- myPart = do --- line <- liftIO $ do -- IO --- putStr \"return? \" --- getLine --- when (take 2 line \/= \"ok\") $ (notfound () >> return \"refused\") --- return \"Hello World!\" --- @ --- --- This example will ask in the console \"return? \" if you type \"ok\" it will --- show \"Hello World!\" and if you type anything else it will return a 404. --- ------------------------------------------------------------------------------ -module Happstack.Server.SimpleHTTP - ( module Happstack.Server.HTTP.Types - , module Happstack.Server.Cookie - -- * SimpleHTTP - , simpleHTTP - , simpleHTTP' - , parseConfig - -- * ServerPartT - , ServerPartT(..) - , ServerPart - , runServerPartT - , mapServerPartT - , mapServerPartT' - , withRequest - , anyRequest - -- * WebT - , WebT(..) - , FilterFun - , Web - , mkWebT - , ununWebT - , runWebT - , mapWebT - -- * Type Classes - , FromReqURI(..) - , ToMessage(..) - - -- * Manipulating requests - , FromData(..) - , ServerMonad(..) - , RqData - , noHandle - , getHeaderM - , escape - , escape' - , multi - -- * Manipulating responses - , FilterMonad(..) - , ignoreFilters - , SetAppend(..) - , FilterT(..) - , WebMonad(..) - , ok - , modifyResponse - , setResponseCode - , badGateway - , internalServerError - , badRequest - , unauthorized - , forbidden - , notFound - , seeOther - , found - , movedPermanently - , tempRedirect - , addCookie - , addCookies - , addHeaderM - , setHeaderM - - -- * guards and building blocks - , guardRq - , dir - , method - , methodSP - , methodM - , methodOnly - , nullDir - , path - , anyPath - , anyPath' - , withData - , withDataFn - , getDataFn - , getData - , require - , requireM - , basicAuth - , uriRest - , flatten - , localContext - -- * proxying - , proxyServe - , rproxyServe - -- * unknown - , debugFilter - , applyRequest - -- * Parsing input and cookies - , lookInput -- :: String -> Data Input - , lookBS -- :: String -> Data B.ByteString - , look -- :: String -> Data String - , lookCookie -- :: String -> Data Cookie - , lookCookieValue -- :: String -> Data String - , readCookieValue -- :: Read a => String -> Data a - , lookRead -- :: Read a => String -> Data a - , lookPairs - -- * XSLT - , xslt ,doXslt - -- * Error Handlng - , errorHandlerSP - , simpleErrorHandler - , spUnwrapErrorT - -- * Output Validation - , setValidator - , setValidatorSP - , validateConf - , runValidator - , wdgHTMLValidator - , noopValidator - , lazyProcValidator - ) where -import qualified Paths_happstack_server as Cabal -import qualified Data.Version as DV -import Happstack.Server.HTTP.Client -import Happstack.Data.Xml.HaXml -import qualified Happstack.Server.MinHaXML as H - -import Happstack.Server.HTTP.Types hiding (Version(..)) -import qualified Happstack.Server.HTTP.Types as Types -import Happstack.Server.HTTP.Listen as Listen -import Happstack.Server.XSLT -import Happstack.Server.SURI (ToSURI) -import Happstack.Util.Common -import Happstack.Server.Cookie -import Happstack.Data -- used by default implementation of fromData -import Control.Applicative -import Control.Concurrent (forkIO) -import Control.Exception (evaluate) -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Error -import Control.Monad.Trans() -import Control.Monad.Maybe -import Control.Monad.Writer as Writer -import Data.Maybe -import Data.Monoid -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.Generics as G -import qualified Data.Map as M -import Text.Html (Html,renderHtml) -import qualified Text.XHtml as XHtml (Html,renderHtml) -import qualified Happstack.Crypto.Base64 as Base64 -import Data.Char -import Data.List -import System.IO -import System.Console.GetOpt -import System.Process (runInteractiveProcess, waitForProcess) -import System.Exit -import Text.Show.Functions () - --- | An alias for WebT when using IO -type Web a = WebT IO a --- | An alias for using ServerPartT when using the IO -type ServerPart a = ServerPartT IO a - --------------------------------------- --- HERE BEGINS ServerPartT definitions - --- | ServerPartT is a container for processing requests and returning results -newtype ServerPartT m a = ServerPartT { unServerPartT :: ReaderT Request (WebT m) a } - deriving (Monad, MonadIO, MonadPlus, Functor) - --- | particularly useful when combined with runWebT to produce --- a @m (Maybe Response)@ from a request. -runServerPartT :: ServerPartT m a -> Request -> WebT m a -runServerPartT = runReaderT . unServerPartT - -withRequest :: (Request -> WebT m a) -> ServerPartT m a -withRequest = ServerPartT . ReaderT - --- | Used to manipulate the containing monad. Very useful when embedding a --- monad into a ServerPartT, since simpleHTTP requires a @ServerPartT IO a@. --- Refer to 'WebT' for an explanation of the structure of the monad. --- --- Here is an example. Suppose you want to embed an ErrorT into your --- ServerPartT to enable throwError and catchError in your Monad. --- --- @ --- type MyServerPartT e m a = ServerPartT (ErrorT e m) a --- @ --- --- Now suppose you want to pass MyServerPartT into a function --- that demands a @ServerPartT IO a@ (e.g. simpleHTTP). You --- can provide the function: --- --- @ --- unpackErrorT:: (Monad m, Show e) => --- -> (ErrorT e m) (Maybe ((Either Response a), FilterFun Response)) --- -> m (Maybe ((Either Response a), FilterFun Response)) --- unpackErrorT handler et = do --- eitherV <- runErrorT et --- case eitherV of --- Left err -> return $ Just (Left "Catastrophic failure " ++ show e, Set $ Endo \r -> r{rsCode = 500}) --- Right x -> return x --- @ --- --- With @unpackErrorT@ you can now call simpleHTTP. Just wrap your @ServerPartT@ list. --- --- @ --- simpleHTTP nullConf $ mapServerPartT unpackErrorT (myPart \`catchError\` myHandler) --- @ --- --- Or alternatively: --- --- @ --- simpleHTTP' unpackErrorT nullConf (myPart \`catchError\` myHandler) --- @ --- --- Also see 'spUnwrapErrorT' for a more sophisticated version of this function --- -mapServerPartT :: (m (Maybe (Either Response a, FilterFun Response)) -> n (Maybe (Either Response b, FilterFun Response))) -> ServerPartT m a -> ServerPartT n b -mapServerPartT f ma = withRequest $ \rq -> mapWebT f (runServerPartT ma rq) - --- | A varient of mapServerPartT where the first argument, also takes a request. --- useful if you want to runServerPartT on a different ServerPartT inside your --- monad (see spUnwrapErrorT) -mapServerPartT' :: (Request -> m (Maybe (Either Response a, FilterFun Response)) -> n (Maybe (Either Response b, FilterFun Response))) -> ServerPartT m a -> ServerPartT n b -mapServerPartT' f ma = withRequest $ \rq -> mapWebT (f rq) (runServerPartT ma rq) -instance MonadTrans (ServerPartT) where - lift m = withRequest (\_ -> lift m) - -instance (Monad m) => Monoid (ServerPartT m a) - where mempty = mzero - mappend = mplus - -instance (Monad m, Functor m) => Applicative (ServerPartT m) where - pure = return - (<*>) = ap - -instance (Monad m, MonadWriter w m) => MonadWriter w (ServerPartT m) where - tell = lift . tell - listen m = withRequest $ \rq -> Writer.listen (runServerPartT m rq) >>= return - pass m = withRequest $ \rq -> pass (runServerPartT m rq) >>= return - -instance (Monad m, MonadError e m) => MonadError e (ServerPartT m) where - throwError e = lift $ throwError e - catchError action handler = withRequest $ \rq -> (runServerPartT action rq) `catchError` ((flip runServerPartT $ rq) . handler) - -instance (Monad m, MonadReader r m) => MonadReader r (ServerPartT m) where - ask = lift ask - local fn m = withRequest $ \rq-> local fn (runServerPartT m rq) - -instance Monad m => FilterMonad Response (ServerPartT m) where - setFilter = anyRequest . setFilter - composeFilter = anyRequest . composeFilter - getFilter m = withRequest $ \rq -> getFilter (runServerPartT m rq) - -instance Monad m => WebMonad Response (ServerPartT m) where - finishWith r = anyRequest $ finishWith r - --- | yes, this is exactly like 'ReaderT' with new names. --- Why you ask? Because ServerT can lift up a ReaderT. --- If you did that, it would shadow ServerT's behavior --- as a ReaderT, thus meaning if you lifted the ReaderT --- you could no longer modify the Request. This way --- you can add a ReaderT to your monad stack without --- any trouble. -class Monad m => ServerMonad m where - askRq :: m Request - localRq :: (Request->Request)->m a->m a - -instance (Monad m) => ServerMonad (ServerPartT m) where - askRq = ServerPartT $ ask - localRq f m = ServerPartT $ local f (unServerPartT m) -------------------------------- --- HERE BEGINS WebT definitions - --- | A monoid operation container. --- If a is a monoid, then SetAppend is a monoid with the following behaviors: --- --- @ --- Set x `mappend` Append y = Set (x `mappend` y) --- Append x `mappend` Append y = Append (x `mappend` y) --- \_ `mappend` Set y = Set y --- @ --- --- A simple way of sumerizing this is, if the left side is Append, then the --- right is appended to the left. If the left side is Set, then the right side --- is ignored. -data SetAppend a = Set a | Append a - deriving (Eq, Show) -instance Monoid a => Monoid (SetAppend a) where - mempty = Append mempty - Set x `mappend` Append y = Set (x `mappend` y) - Append x `mappend` Append y = Append (x `mappend` y) - _ `mappend` Set y = Set y - -value :: SetAppend t -> t -value (Set x) = x -value (Append x) = x - -instance Functor (SetAppend) where - fmap f (Set x) = Set $ f x - fmap f (Append x) = Append $ f x - --- | @FilterFun@ is a lot more fun to type than @SetAppend (Dual (Endo a))@ -type FilterFun a = SetAppend (Dual (Endo a)) - -newtype FilterT a m b = - FilterT { unFilterT :: WriterT (FilterFun a) m b } - deriving (Monad, MonadTrans, Functor, MonadIO) - --- | A set of functions for manipulating filters. A ServerPartT implements --- FilterMonad Response so these methods are the fundamental ways of --- manipulating the response object, especially before you've converted your --- monadic value to a 'Response' -class Monad m => FilterMonad a m | m->a where - -- | Ignores all previous - -- alterations to your filter - -- - -- As an example: - -- - -- @ - -- do - -- composeFilter f - -- setFilter g - -- return \"Hello World\" - -- @ - -- - -- setFilter g will cause the first composeFilter to be - -- ignored. - setFilter :: (a->a) -> m () - -- | - -- composes your filter function with the - -- existing filter function. - composeFilter :: (a->a) -> m () - -- | retrives the filter from the environment - getFilter :: m b -> m (b,a->a) - -instance (Monad m) => FilterMonad a (FilterT a m) where - setFilter f = FilterT $ Writer.tell $ Set $ Dual $ Endo f - composeFilter f = FilterT $ Writer.tell $ Append $ Dual $ Endo f - getFilter m = FilterT $ Writer.listens (appEndo . getDual . value) (unFilterT m) - --- | The basic response building object. --- It is worth discussing the unpacked structure of WebT a bit as it's exposed --- in 'mapServerPartT' and 'mapWebT'. --- --- A fully unpacked WebT has a structure that looks like: --- --- @ --- ununWebT $ WebT m a :: m (Maybe (Either Response a, FilterFun Response)) --- @ --- --- So, ignoring m, as it is just the containing Monad, the outermost layer is --- a Maybe. This is 'Nothing' if 'mzero' was called or @Just (Either Response --- a, SetAppend (Endo Response))@ if 'mzero' wasn't called. Inside the Maybe, --- there is a pair. The second element of the pair is our filter function --- @FilterFun Response@. @FilterFun Response@ is a type alias for @SetAppend --- (Dual (Endo Response))@. This is just a wrapper for a @Response->Response@ --- function with a particular Monoid behavior. The value --- --- @ --- Append (Dual (Endo f)) --- @ --- --- Causes f to be composed with the previous filter. --- --- @ --- Set (Dual (Endo f)) --- @ --- --- Causes f to not be composed with the previous filter. --- --- Finally, the first element of the pair is either @Left Response@ or @Right a@. --- --- Another way of looking at all these pieces is from the behaviors they control. The Maybe --- controls the mzero behavior. @Set (Endo f)@ comes from the setFilter behavior. --- Likewise, @Append (Endo f)@ is from composeFilter. @Left Response@ is what you --- get when you call "finishWith" and @Right a@ is the normal exit. --- --- An example case statement looks like: --- @ --- ex1 webt = do --- val <- ununWebT webt --- case val of --- Nothing -> Nothing -- this is the interior value when mzero was used --- Just (Left r, f) -> Just (Left r, f) -- r is the value that was passed into "finishWith" --- -- f is our filter function --- Just (Right a, f) -> Just (Right a, f) -- a is our normal monadic value --- -- f is still our filter function --- @ --- -newtype WebT m a = WebT { unWebT :: ErrorT Response (FilterT (Response) (MaybeT m)) a } - deriving (MonadIO, Functor) - -instance Monad m => Monad (WebT m) where - m >>= f = WebT $ unWebT m >>= unWebT . f - return a = WebT $ return a - fail s = mkFailMessage s - -instance Error Response where - strMsg = toResponse - -class Monad m => WebMonad a m | m->a where - -- | A control structure - -- It ends the computation and returns the Response you passed into it - -- immediately. This provides an alternate escape route. In particular - -- it has a monadic value of any type. And unless you call @'setFilter' id@ - -- first your response filters will be applied normally. - -- - -- Extremely useful when you're deep inside a monad and decide that you - -- want to return a completely different content type, since it doesn't - -- force you to convert all your return types to Response early just to - -- accomodate this. - finishWith :: a -> m b - -instance (Monad m) => WebMonad Response (WebT m) where - finishWith r = WebT $ throwError r - -instance MonadTrans WebT where - lift = WebT . lift . lift . lift - -instance (Monad m) => MonadPlus (WebT m) where - -- | Aborts a computation. - -- - -- This is primarily useful because msum will take an array - -- of MonadPlus and return the first one that isn't mzero, - -- which 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) - --- | deprecated. use mzero -noHandle :: (MonadPlus m) => m a -noHandle = mzero -{-# DEPRECATED noHandle "Use mzero" #-} - -instance (Monad m) => FilterMonad Response (WebT m) where - setFilter f = WebT $ lift $ setFilter $ f - composeFilter f = WebT . lift . composeFilter $ f - getFilter m = WebT $ ErrorT $ getFilter (runErrorT $ unWebT m) >>= liftWebT - where liftWebT (Left r, _) = return $ Left r - liftWebT (Right a, f) = return $ Right (a, f) - -instance (Monad m) => Monoid (WebT m a) where - mempty = mzero - mappend = mplus - --- | takes your WebT, converts the monadic value to a Response, --- applys your filter, and returns it wrapped in a Maybe. -runWebT :: (ToMessage b, Monad m) => WebT m b -> m (Maybe Response) -runWebT m = runMaybeT $ do - (r,ed) <- runWriterT $ unFilterT $ runErrorT $ unWebT $ m - let f = appEndo $ getDual $ value ed - return $ either (f) (f . toResponse) r --- | for when you really need to unpack a WebT entirely (and not --- just unwrap the first layer with unWebT) -ununWebT :: WebT m a - -> m (Maybe - (Either Response a, - FilterFun Response)) -ununWebT = runMaybeT . runWriterT . unFilterT . runErrorT . unWebT - --- | for wrapping a WebT back up. @mkWebT . ununWebT = id@ -mkWebT :: m (Maybe - (Either Response a, - FilterFun Response)) -> WebT m a -mkWebT = WebT . ErrorT . FilterT . WriterT . MaybeT - --- | see 'mapServerPartT' for a discussion of this function -mapWebT :: (m (Maybe (Either Response a, FilterFun Response)) -> n (Maybe (Either Response b, FilterFun Response))) -> WebT m a -> WebT n b -mapWebT f ma = mkWebT $ f (ununWebT ma) - - -instance (Monad m, Functor m) => Applicative (WebT m) where - pure = return - (<*>) = ap - -instance MonadReader r m => MonadReader r (WebT m) where - ask = lift ask - local fn m = mkWebT $ local fn (ununWebT m) - -instance MonadState st m => MonadState st (WebT m) where - get = lift get - put = lift . put - -instance MonadError e m => MonadError e (WebT m) where - throwError err = lift $ throwError err - catchError action handler = mkWebT $ catchError (ununWebT action) (ununWebT . handler) - -instance MonadWriter w m => MonadWriter w (WebT m) where - tell = lift . Writer.tell - listen m = mkWebT $ Writer.listen (ununWebT m) >>= (return . liftWebT) - where liftWebT (Nothing, _) = Nothing - liftWebT (Just (Left x,f), _) = Just (Left x,f) - liftWebT (Just (Right x,f),w) = Just (Right (x,w),f) - pass m = mkWebT $ ununWebT m >>= liftWebT - where liftWebT Nothing = return Nothing - liftWebT (Just (Left x,f)) = return $ Just (Left x, f) - liftWebT (Just (Right x,f)) = pass (return x)>>= (\a -> return $ Just (Right a,f)) - --- | An alias for setFilter id --- It resets all your filters -ignoreFilters :: (FilterMonad a m) => m () -ignoreFilters = setFilter id - --- | Used to ignore all your filters --- and immediately end the computation. A combination of --- 'ignoreFilters' and 'finishWith' -escape :: (WebMonad a m, FilterMonad a m) => m a -> m b -escape gen = ignoreFilters >> gen >>= finishWith - --- | An alternate form of 'escape' that can --- be easily used within a do block. -escape' :: (WebMonad a m, FilterMonad a m) => a -> m b -escape' a = ignoreFilters >> finishWith a - ----------------------------------------------- --- additional types - - --- | An array of 'OptDescr', useful for processing --- command line options into an 'Conf' for 'simpleHTTP' -ho :: [OptDescr (Conf -> Conf)] -ho = [Option [] ["http-port"] (ReqArg (\h c -> c { port = read h }) "port") "port to bind http server"] - --- | parseConfig tries to parse your command line options --- into a Conf. -parseConfig :: [String] -> Either [String] Conf -parseConfig args - = case getOpt Permute ho args of - (flags,_,[]) -> Right $ foldr ($) nullConf flags - (_,_,errs) -> Left errs - --- | Use the built-in web-server to serve requests according to a 'ServerPartT'. --- Use msum to pick the first handler from a list of handlers that doesn't call --- noHandle. -simpleHTTP :: (ToMessage a) => Conf -> ServerPartT IO a -> IO () -simpleHTTP = simpleHTTP' id - --- | a combination of simpleHTTP and 'mapServerPartT'. See 'mapServerPartT' for a discussion --- of the first argument of this function. -simpleHTTP' :: (Monad m, ToMessage b) => - (m (Maybe (Either Response a, FilterFun Response)) - -> IO (Maybe (Either Response b, FilterFun Response))) - -> Conf - -> ServerPartT m a - -> IO () -simpleHTTP' toIO conf hs = do - Listen.listen conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req)) - - --- | Generate a result from a 'ServerPart' and a 'Request'. This is mainly used --- by CGI (and fast-cgi) wrappers. -simpleHTTP'' :: (ToMessage b, Monad m) => ServerPartT m b -> Request -> m Response -simpleHTTP'' hs req = (runWebT $ runServerPartT hs req) >>= (return . (maybe standardNotFound id)) - where - standardNotFound = setHeader "Content-Type" "text/html" $ toResponse notFoundHtml - - --- | a wrapper for Read apparently. Pretty much only used for 'path' and probably --- unnecessarily, as it is exactly "readM" -class FromReqURI a where - fromReqURI :: String -> Maybe a - - - -instance FromReqURI String where fromReqURI = Just -instance FromReqURI Int where fromReqURI = readM -instance FromReqURI Integer where fromReqURI = readM -instance FromReqURI Float where fromReqURI = readM -instance FromReqURI Double where fromReqURI = readM - -type RqData a = ReaderT ([(String,Input)], [(String,Cookie)]) Maybe a - --- | Useful for withData and getData' implement this on your preferred type --- to use those functions -class FromData a where - fromData :: RqData a - -instance (Eq a,Show a,Xml a,G.Data a) => FromData a where - fromData = do mbA <- lookPairs >>= return . normalize . fromPairs - case mbA of - Just a -> return a - Nothing -> fail "FromData G.Data failure" --- fromData = lookPairs >>= return . normalize . fromPairs - -instance (FromData a, FromData b) => FromData (a,b) where - fromData = liftM2 (,) fromData fromData -instance (FromData a, FromData b, FromData c) => FromData (a,b,c) where - fromData = liftM3 (,,) fromData fromData fromData -instance (FromData a, FromData b, FromData c, FromData d) => FromData (a,b,c,d) where - fromData = liftM4 (,,,) fromData fromData fromData fromData -instance FromData a => FromData (Maybe a) where - fromData = fmap Just fromData `mplus` return Nothing - --- | --- Minimal definition: 'toMessage' --- --- Used to convert arbitrary types into an HTTP response. You need to implement --- this if you want to pass @ServerPartT m@ containing your type into simpleHTTP -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 val = - let bs = toMessage val - res = Response 200 M.empty nullRsFlags bs Nothing - in setHeaderBS (B.pack "Content-Type") (toContentType val) - res - -instance ToMessage [Element] where - toContentType _ = B.pack "application/xml" - toMessage [el] = L.pack $ H.simpleDoc H.NoStyle $ toHaXmlEl el -- !! OPTIMIZE - toMessage x = error ("Happstack.Server.SimpleHTTP 'instance ToMessage [Element]' Can't handle " ++ show x) - - - - -instance ToMessage () where - toContentType _ = B.pack "text/plain" - toMessage () = L.empty -instance ToMessage String where - toContentType _ = B.pack "text/plain" - toMessage = L.pack -instance ToMessage Integer where - toMessage = toMessage . show -instance ToMessage a => ToMessage (Maybe a) where - toContentType _ = toContentType (undefined :: a) - toMessage Nothing = toMessage "nothing" - toMessage (Just x) = toMessage x - - -instance ToMessage Html where - toContentType _ = B.pack "text/html" - toMessage = L.pack . renderHtml - -instance ToMessage XHtml.Html where - toContentType _ = B.pack "text/html" - toMessage = L.pack . XHtml.renderHtml - -instance ToMessage Response where - toResponse = id - -instance (Xml a)=>ToMessage a where - toContentType = toContentType . toXml - toMessage = toMessage . toPublicXml - --- toMessageM = toMessageM . toPublicXml - - -class MatchMethod m where matchMethod :: m -> Method -> Bool -instance MatchMethod Method where matchMethod m = (== m) -instance MatchMethod [Method] where matchMethod methods = (`elem` methods) -instance MatchMethod (Method -> Bool) where matchMethod f = f -instance MatchMethod () where matchMethod () _ = True - --- | flatten turns your arbitrary @m a@ and converts it too --- a @m 'Response'@ with @'toResponse'@ -flatten :: (ToMessage a, Functor f) => f a -> f Response -flatten = fmap toResponse - --- | This is kinda like a very oddly shaped mapServerPartT or mapWebT --- You probably want one or the other of those. -localContext :: Monad m => (WebT m a -> WebT m' a) -> ServerPartT m a -> ServerPartT m' a -localContext fn hs - = withRequest $ \rq -> fn (runServerPartT hs rq) - - --- | Get a header out of the request -getHeaderM :: (ServerMonad m) => String -> m (Maybe B.ByteString) -getHeaderM a = askRq >>= return . (getHeader a) - --- | adds headers into the response. --- This method does not overwrite any existing header of --- the same name, hence the name addHeaderM. If you --- want to replace a header use setHeaderM. -addHeaderM :: (FilterMonad Response m) => String -> String -> m () -addHeaderM a v = composeFilter $ \res-> addHeader a v res - --- | sets a header into the response. This will replace --- an existing header of the same name. Use addHeaderM, if you --- want to add more than one header of the same name. -setHeaderM :: (FilterMonad Response m) => String -> String -> m () -setHeaderM a v = composeFilter $ \res -> setHeader a v res -------------------------------------- --- guards - --- | guard using an arbitrary function on the request -guardRq :: (ServerMonad m, MonadPlus m) => (Request -> Bool) -> m () -guardRq f = do - rq <- askRq - when ( f rq /= True ) mzero - --- | Guard against the method. This function also guards against --- any remaining path segments. See methodOnly for the version --- that guards only by method -methodM :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m () -methodM meth = methodOnly meth >> nullDir - --- | guard against the method only. (as opposed to 'methodM') -methodOnly :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m () -methodOnly meth = guardRq $ \rq -> matchMethod meth (rqMethod rq) - --- | Guard against the method. Note, this function also guards against any --- remaining path segments. -methodSP :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m b-> m b -methodSP m handle = methodM m >> handle - --- | Guard against the method. Note, this function also guards against any --- remaining path segments. This function id deprecated. You can probably --- just use methodSP (or methodM) now. -method :: (MatchMethod method, Monad m) => method -> WebT m a -> ServerPartT m a -method m handle = methodSP m (anyRequest handle) -{-# DEPRECATED method "you should be able to use methodSP" #-} - --- | Guard against non-empty remaining path segments -nullDir :: (ServerMonad m, MonadPlus m) => m () -nullDir = guardRq $ \rq -> null (rqPaths rq) - --- | Pop a path element and run the @ServerPartT@ if it matches the given string. -dir :: (ServerMonad m, MonadPlus m) => String -> m a -> m a -dir staticPath handle = - do - rq <- askRq - case rqPaths rq of - (p:xs) | p == staticPath -> localRq (\newRq -> newRq{rqPaths = xs}) handle - | otherwise -> mzero - _ -> mzero - --- | Pop a path element and parse it. Annoyingly enough, rather than just using Read --- (or providing a parser argument), this method uses 'FromReqURI' which is just a wrapper --- for Read. -path :: (FromReqURI a, MonadPlus m, ServerMonad m) => (a -> m b) -> m b -path handle = do - rq <- askRq - case rqPaths rq of - (p:xs) | Just a <- fromReqURI p - -> localRq (\newRq -> newRq{rqPaths = xs}) (handle a) - | otherwise -> mzero - _ -> mzero - --- | grabs the rest of the URL (dirs + query) and passes it to your handler -uriRest :: (ServerMonad m) => (String -> m a) -> m a -uriRest handle = askRq >>= handle . rqURL - --- | pops any path element and ignores when chosing a ServerPartT to handle the --- --- request. -anyPath :: (ServerMonad m, MonadPlus m) => m r -> m r -anyPath x = path $ (\(_::String) -> x) - --- | Deprecated. Use 'anyPath'. -anyPath' :: (ServerMonad m, MonadPlus m) => m r -> m r -anyPath' = anyPath -{-# DEPRECATED anyPath' "Use anyPath" #-} - --- | used to read parse your request with a RqData (a ReaderT, basically) --- For example here is a simple GET or POST variable based authentication --- guard. It handles the request with errorHandler if authentication fails. --- --- @ --- myRqData = do --- username <- lookInput \"username\" --- password <- lookInput \"password\" --- return (username, password) --- checkAuth errorHandler = do --- d <- getData myRqDataA --- case d of --- Nothing -> errorHandler --- Just a | isValid a -> mzero --- Just a | otherwise -> errorHandler --- @ -getDataFn :: (ServerMonad m) => RqData a -> m (Maybe a) -getDataFn rqData = do - rq <- askRq - return $ runReaderT rqData (rqInputs rq, rqCookies rq) - --- | An varient of getData that uses FromData to chose your --- RqData for you. The example from 'getData' becomes: --- --- @ --- myRqData = do --- username <- lookInput \"username\" --- password <- lookInput \"password\" --- return (username, password) --- instance FromData (String,String) where --- fromData = myRqData --- checkAuth errorHandler = do --- d <- getData\' --- case d of --- Nothing -> errorHandler --- Just a | isValid a -> mzero --- Just a | otherwise -> errorHandler --- @ -getData :: (ServerMonad m, FromData a) => m (Maybe a) -getData = getDataFn fromData - --- | Retrieve data from the input query or the cookies. -withData :: (FromData a, MonadPlus m, ServerMonad m) => (a -> m r) -> m r -withData = withDataFn fromData - --- | withDataFn is like with data, but you pass in a RqData monad --- for reading. -withDataFn :: (MonadPlus m, ServerMonad m) => RqData a -> (a -> m r) -> m r -withDataFn fn handle = do - d <- getDataFn fn - case d of - Nothing -> mzero - Just a -> handle a - --- | proxyServe is for creating ServerPartT's that 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 immediatly 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) - --- | Takes a proxy Request and creates 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 :: (MonadIO m, WebMonad Response m) => - String -- ^ defaultHost - -> [(String, String)] -- ^ map to look up hostname mappings. For the reverse proxy - -> ServerPartT m Response -- ^ the result is a ServerPartT that will reverse proxy for you. -rproxyServe defaultHost list = withRequest $ \rq -> - liftIO (getResponse (unrproxify defaultHost list rq)) >>= - either (badGateway . toResponse . show) (escape') - --- | Run an IO action and, if it returns @Just@, pass it to the second argument. -require :: (MonadIO m, MonadPlus m) => IO (Maybe a) -> (a -> m r) -> m r -require fn handle = do - mbVal <- liftIO fn - case mbVal of - Nothing -> mzero - Just a -> handle a - --- | A varient of require that can run in any monad, not just IO -requireM :: (MonadTrans t, Monad m, MonadPlus (t m)) => m (Maybe a) -> (a -> t m r) -> t m r -requireM fn handle = do - mbVal <- lift fn - case mbVal of - Nothing -> mzero - Just a -> handle a - --- | Use @cmd@ to transform XML against @xslPath@. --- This function only acts if the content-type is @application\/xml@. -xslt :: (MonadIO m, MonadPlus m, ToMessage r) => - XSLTCmd -- ^ XSLT preprocessor. Usually 'xsltproc' or 'saxon'. - -> XSLPath -- ^ Path to xslt stylesheet. - -> m r -- ^ Affected @ServerParts@. - -> m Response -xslt cmd xslPath parts = do - res <- parts - if toContentType res == B.pack "application/xml" - then liftM toResponse (doXslt cmd xslPath (toResponse res)) - else return (toResponse res) - -doXslt :: (MonadIO m) => - XSLTCmd -> XSLPath -> Response -> m Response -doXslt cmd xslPath res = - do new <- liftIO $ procLBSIO cmd xslPath $ rsBody res - return $ setHeader "Content-Type" "text/html" $ - setHeader "Content-Length" (show $ L.length new) $ - res { rsBody = new } - --- | deprecated. Same as 'composeFilter' -modifyResponse :: (FilterMonad a m) => (a -> a) -> m() -modifyResponse = composeFilter -{-# DEPRECATED modifyResponse "Use composeFilter" #-} - --- | sets the return code in your response -setResponseCode :: FilterMonad Response m => Int -> m () -setResponseCode code - = composeFilter $ \r -> r{rsCode = code} - --- | adds the cookie with a timeout to the response -addCookie :: (FilterMonad Response m) => Seconds -> Cookie -> m () -addCookie sec = (addHeaderM "Set-Cookie") . mkCookieHeader sec - --- | adds the list of cookie timeout pairs to the response -addCookies :: (FilterMonad Response m) => [(Seconds, Cookie)] -> m () -addCookies = mapM_ (uncurry addCookie) - --- | same as setResponseCode status >> return val -resp :: (FilterMonad Response m) => Int -> b -> m b -resp status val = setResponseCode status >> return val - --- | Respond with @200 OK@. -ok :: (FilterMonad Response m) => a -> m a -ok = resp 200 - -internalServerError :: (FilterMonad Response m) => a -> m a -internalServerError = resp 500 - -badGateway :: (FilterMonad Response m) => a -> m a -badGateway = resp 502 - --- | Respond with @400 Bad Request@. -badRequest :: (FilterMonad Response m) => a -> m a -badRequest = resp 400 - --- | Respond with @401 Unauthorized@. -unauthorized :: (FilterMonad Response m) => a -> m a -unauthorized = resp 401 - --- | Respond with @403 Forbidden@. -forbidden :: (FilterMonad Response m) => a -> m a -forbidden = resp 403 - --- | Respond with @404 Not Found@. -notFound :: (FilterMonad Response m) => a -> m a -notFound = resp 404 - --- | Respond with @303 See Other@. -seeOther :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res -seeOther uri res = do modifyResponse $ redirect 303 uri - return res - --- | Respond with @302 Found@. -found :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res -found uri res = do modifyResponse $ redirect 302 uri - return res - --- | Respond with @301 Moved Permanently@. -movedPermanently :: (FilterMonad Response m, ToSURI a) => a -> res -> m res -movedPermanently uri res = do modifyResponse $ redirect 301 uri - return res - --- | Respond with @307 Temporary Redirect@. -tempRedirect :: (FilterMonad Response m, ToSURI a) => a -> res -> m res -tempRedirect val res = do modifyResponse $ redirect 307 val - return res - --- | deprecated. Just use msum -multi :: Monad m => [ServerPartT m a] -> ServerPartT m a -multi = msum -{-# DEPRECATED multi "Use msum instead" #-} - --- | what is this for, exactly? I don't understand why @Show a@ is even in the context --- This appears to do nothing at all. -debugFilter :: (MonadIO m, Show a) => ServerPartT m a -> ServerPartT m a -debugFilter handle = - withRequest $ \rq -> do - r <- runServerPartT handle rq - return r - --- | a constructor for a ServerPartT when you don't care about the request -anyRequest :: Monad m => WebT m a -> ServerPartT m a -anyRequest x = withRequest $ \_ -> x - --- | again, why is this useful? -applyRequest :: (ToMessage a, Monad m) => - ServerPartT m a -> Request -> Either (m Response) b -applyRequest hs = simpleHTTP'' hs >>= return . Left - --- | a simple HTTP basic authentication guard -basicAuth :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadPlus m) => - String -- ^ the realm name - -> M.Map String String -- ^ the username password map - -> m a -- ^ the part to guard - -> m a -basicAuth realmName authMap xs = basicAuthImpl `mplus` xs - where - basicAuthImpl = do - aHeader <- getHeaderM "authorization" - case aHeader of - Nothing -> err - Just x -> case parseHeader x of - (name, ':':password) | validLogin name password -> mzero - | otherwise -> err - _ -> err - validLogin name password = M.lookup name authMap == Just password - parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6 - headerName = "WWW-Authenticate" - headerValue = "Basic realm=\"" ++ realmName ++ "\"" - err = do - unauthorized () - setHeaderM headerName headerValue - escape' $ toResponse "Not authorized" - --------------------------------------------------------------- --- Query/Post data validating --------------------------------------------------------------- - --- | Useful inside the RqData monad. Gets the named input parameter (either --- from a POST or a GET) -lookInput :: String -> RqData Input -lookInput name - = do inputs <- asks fst - case lookup name inputs of - Nothing -> fail "input not found" - Just i -> return i - --- | Gets the named input parameter as a lazy byte string -lookBS :: String -> RqData L.ByteString -lookBS = fmap inputValue . lookInput - --- | Gets the named input as a String -look :: String -> RqData String -look = fmap L.unpack . lookBS - --- | Gets the named cookie --- the cookie name is case insensitive -lookCookie :: String -> RqData Cookie -lookCookie name - = do cookies <- asks snd - case lookup (map toLower name) cookies of -- keys are lowercased - Nothing -> fail "cookie not found" - Just c -> return c - --- | gets the named cookie as a string -lookCookieValue :: String -> RqData String -lookCookieValue = fmap cookieValue . lookCookie - --- | gets the named cookie as the requested Read type -readCookieValue :: Read a => String -> RqData a -readCookieValue name = readM =<< fmap cookieValue (lookCookie name) - --- | like look, but Reads for you. -lookRead :: Read a => String -> RqData a -lookRead name = readM =<< look name - --- | gets all the input parameters, and converts them to a string -lookPairs :: RqData [(String,String)] -lookPairs = asks fst >>= return . map (\(n,vbs)->(n,L.unpack $ inputValue vbs)) - - --------------------------------------------------------------- --- Error Handling --------------------------------------------------------------- - --- | This ServerPart modifier enables the use of throwError and catchError inside the --- WebT actions, by adding the ErrorT monad transformer to the stack. --- --- You can wrap the complete second argument to 'simpleHTTP' in this function. --- -errorHandlerSP :: (Monad m, Error e) => (Request -> e -> WebT m a) -> ServerPartT (ErrorT e m) a -> ServerPartT m a -errorHandlerSP handler sps = withRequest $ \req -> mkWebT $ do - eer <- runErrorT $ ununWebT $ runServerPartT sps req - case eer of - Left err -> ununWebT (handler req err) - Right res -> return res -{-# DEPRECATED errorHandlerSP "Use spUnwrapErrorT" #-} - --- | An example error Handler to be used with 'spUnWrapErrorT', which returns the --- error message as a plain text message to the browser. --- --- Another possibility is to store the error message, e.g. as a FlashMsg, and --- then redirect the user somewhere. -simpleErrorHandler :: (Monad m) => String -> ServerPartT m Response -simpleErrorHandler err = ok $ toResponse $ ("An error occured: " ++ err) - --- | This is a for use with mapServerPartT\' It it unwraps --- the interior monad for use with simpleHTTP. If you --- have a ServerPartT (ErrorT e m) a, this will convert --- that monad into a ServerPartT m a. Used with --- mapServerPartT\' to allow throwError and catchError inside your --- monad. Eg. --- --- @ --- simpleHTTP conf $ mapServerPartT\' (spUnWrapErrorT failurePart) $ myPart \`catchError\` errorPart --- @ --- --- Note that @failurePart@ will only be run if errorPart threw an error --- so it doesn\'t have to be very complex. -spUnwrapErrorT:: Monad m => - (e -> ServerPartT m a) - -> Request - -> ErrorT e m (Maybe (Either Response a, FilterFun Response)) - -> m (Maybe (Either Response a, FilterFun Response)) -spUnwrapErrorT handler rq = \x -> do - err <- runErrorT x - case err of - Left e -> ununWebT $ runServerPartT (handler e) rq - Right a -> return a - --------------------------------------------------------------- --- * Output validation --------------------------------------------------------------- - --- |Set the validator which should be used for this particular 'Response' --- when validation is enabled. --- --- Calling this function does not enable validation. That can only be --- done by enabling the validation in the 'Conf' that is passed to --- 'simpleHTTP'. --- --- You do not need to call this function if the validator set in --- 'Conf' does what you want already. --- --- Example: (use 'noopValidator' instead of the default supplied by 'validateConf') --- --- @ --- simpleHTTP validateConf . anyRequest $ ok . setValidator noopValidator =<< htmlPage --- @ --- --- See also: 'validateConf', 'wdgHTMLValidator', 'noopValidator', 'lazyProcValidator' -setValidator :: (Response -> IO Response) -> Response -> Response -setValidator v r = r { rsValidator = Just v } - --- |ServerPart version of 'setValidator' --- --- Example: (Set validator to 'noopValidator') --- --- @ --- simpleHTTP validateConf $ setValidatorSP noopValidator (dir "ajax" ... ) --- @ --- --- See also: 'setValidator' -setValidatorSP :: (Monad m, ToMessage r) => (Response -> IO Response) -> m r -> m Response -setValidatorSP v sp = return . setValidator v . toResponse =<< sp - --- |This extends 'nullConf' by enabling validation and setting --- 'wdgHTMLValidator' as the default validator for @text\/html@. --- --- Example: --- --- @ --- simpleHTTP validateConf . anyRequest $ ok htmlPage --- @ -validateConf :: Conf -validateConf = nullConf { validator = Just wdgHTMLValidator } - --- |Actually perform the validation on a 'Response' --- --- Run the validator specified in the 'Response'. If none is provide --- use the supplied default instead. --- --- Note: This function will run validation unconditionally. You --- probably want 'setValidator' or 'validateConf'. -runValidator :: (Response -> IO Response) -> Response -> IO Response -runValidator defaultValidator r = - case rsValidator r of - Nothing -> defaultValidator r - (Just altValidator) -> altValidator r - --- |Validate @text\/html@ content with @WDG HTML Validator@. --- --- This function expects the executable to be named @validate@ --- and it must be in the default @PATH@. --- --- See also: 'setValidator', 'validateConf', 'lazyProcValidator' -wdgHTMLValidator :: (MonadIO m, ToMessage r) => r -> m Response -wdgHTMLValidator = liftIO . lazyProcValidator "validate" ["-w","--verbose","--charset=utf-8"] Nothing Nothing handledContentTypes . toResponse - where - handledContentTypes (Just ct) = elem (takeWhile (\c -> c /= ';' && c /= ' ') (B.unpack ct)) [ "text/html", "application/xhtml+xml" ] - handledContentTypes Nothing = False - --- |A validator which always succeeds. --- --- Useful for selectively disabling validation. For example, if you --- are sending down HTML fragments to an AJAX application and the --- default validator only understands complete documents. -noopValidator :: Response -> IO Response -noopValidator = return - --- |Validate the 'Response' using an external application. --- --- If the external application returns 0, the original response is --- returned unmodified. If the external application returns non-zero, a 'Response' --- containing the error messages and original response body is --- returned instead. --- --- This function also takes a predicate filter which is applied to the --- content-type of the response. The filter will only be applied if --- the predicate returns true. --- --- NOTE: This function requirse the use of -threaded to avoid blocking. --- However, you probably need that for Happstack anyway. --- --- See also: 'wdgHTMLValidator' -lazyProcValidator :: FilePath -- ^ name of executable - -> [String] -- ^ arguements to pass to the executable - -> Maybe FilePath -- ^ optional path to working directory - -> Maybe [(String, String)] -- ^ optional environment (otherwise inherit) - -> (Maybe B.ByteString -> Bool) -- ^ content-type filter - -> Response -- ^ Response to validate - -> IO Response -lazyProcValidator exec args wd env mimeTypePred response - | mimeTypePred (getHeader "content-type" response) = - do (inh, outh, errh, ph) <- runInteractiveProcess exec args wd env - out <- hGetContents outh - err <- hGetContents errh - forkIO $ do L.hPut inh (rsBody response) - hClose inh - forkIO $ evaluate (length out) >> return () - forkIO $ evaluate (length err) >> return () - ec <- waitForProcess ph - case ec of - ExitSuccess -> return response - (ExitFailure _) -> - return $ toResponse (unlines ([ "ExitCode: " ++ show ec - , "stdout:" - , out - , "stderr:" - , err - , "input:" - ] ++ - showLines (rsBody response))) - | otherwise = return response - where - column = " " ++ (take 120 $ concatMap (\n -> " " ++ show n) (drop 1 $ cycle [0..9::Int])) - showLines :: L.ByteString -> [String] - showLines string = column : zipWith (\n -> \l -> show n ++ " " ++ (L.unpack l)) [1::Integer ..] (L.lines string) - -mkFailMessage :: (FilterMonad Response m, WebMonad Response m) => String -> m b -mkFailMessage s = do - ignoreFilters - internalServerError () - setHeaderM "Content-Type" "text/html" - res <- return $ toResponse $ failHtml s - finishWith $ res - -failHtml:: String->String -failHtml errString = "Happstack " - ++ ver ++ " Internal Server Error" - ++ "

Happstack " ++ ver ++ "

" - ++ "

Something went wrong here
" - ++ "Internal server error
" - ++ "Everything has stopped

" - ++ "

The error was \"" ++ errString ++ "\"

" - where ver = DV.showVersion Cabal.version - -notFoundHtml :: String -notFoundHtml = "Happstack " - ++ ver ++ " File not found" - ++ "

Happstack " ++ ver ++ "

" - ++ "

Your file is not found
" - ++ "To try again is useless
" - ++ "It is just not here

" - ++ "" - where ver = DV.showVersion Cabal.version +{-# LANGUAGE CPP #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Happstack.Server.SimpleHTTP +-- Copyright : (c) Happstack.com 2010; (c) HAppS Inc 2007 +-- License : BSD-like +-- +-- Maintainer : Happstack team +-- Stability : provisional +-- Portability : requires mtl +-- +-- 'simpleHTTP' is a self-contained HTTP server which can be used to +-- run a 'ServerPart'. +-- +-- A very simple, \"Hello World!\" web app looks like: +-- +-- > import Happstack.Server +-- > main = simpleHTTP nullConf $ ok "Hello World!" +-- +-- By default the server will listen on port 8000. Run the app and point your browser at: +-- +-- For FastCGI support see: +----------------------------------------------------------------------------- +module Happstack.Server.SimpleHTTP + ( -- * SimpleHTTP + simpleHTTP + , simpleHTTP' + , simpleHTTP'' + , simpleHTTPWithSocket + , simpleHTTPWithSocket' + , bindPort + , bindIPv4 + , parseConfig + , runWebT + , waitForTermination + -- * Re-exported modules + -- ** Basic ServerMonad functionality + , module Happstack.Server.Monads + -- ** HTTP Realm Authentication + , module Happstack.Server.Auth + -- ** Create and Set Cookies (see also "Happstack.Server.RqData") + , module Happstack.Server.Cookie + -- ** Error Handling + , module Happstack.Server.Error + -- ** Creating Responses + , module Happstack.Server.Response + -- ** Request Routing + , module Happstack.Server.Routing + -- ** Looking up values in Query String, Request Body, and Cookies + , module Happstack.Server.RqData + -- ** Output Validation + , module Happstack.Server.Validation + , module Happstack.Server.Types +-- , module Happstack.Server.Internal.Monads + + ) where + +-- re-exports + +import Happstack.Server.Auth +import Happstack.Server.Monads +import Happstack.Server.Cookie +import Happstack.Server.Error +import Happstack.Server.Types +import Happstack.Server.Routing +import Happstack.Server.RqData +import Happstack.Server.Response +import Happstack.Server.Validation + +import Control.Monad +import Data.Maybe (fromMaybe) +import qualified Data.Version as DV +import Happstack.Server.Internal.Monads (FilterFun, WebT(..), unFilterFun, runServerPartT, ununWebT) +import qualified Happstack.Server.Internal.Listen as Listen (listen, listen',listenOn, listenOnIPv4) -- So that we can disambiguate 'Writer.listen' +import Network.Socket (Socket) +import qualified Paths_happstack_server as Cabal +import System.Console.GetOpt ( OptDescr(Option) + , ArgDescr(ReqArg) + , ArgOrder(Permute) + , getOpt + ) +#ifdef UNIX +import Control.Concurrent.MVar +import System.Posix.Signals hiding (Handler) +import System.Posix.IO ( stdInput ) +import System.Posix.Terminal ( queryTerminal ) +#endif + +-- | An array of 'OptDescr', useful for processing command line +-- options into an 'Conf' for 'simpleHTTP'. +ho :: [OptDescr (Conf -> Conf)] +ho = [Option [] ["http-port"] (ReqArg (\h c -> c { port = readDec' h }) "port") "port to bind http server"] + +-- | Parse command line options into a 'Conf'. +parseConfig :: [String] -> Either [String] Conf +parseConfig args + = case getOpt Permute ho args of + (flags,_,[]) -> Right $ foldr ($) nullConf flags + (_,_,errs) -> Left errs + +-- |start the server, and handle requests using the supplied +-- 'ServerPart'. +-- +-- This function will not return, though it may throw an exception. +-- +-- NOTE: The server will only listen on IPv4 due to portability issues +-- in the "Network" module. For IPv6 support, use +-- 'simpleHTTPWithSocket' with custom socket. +simpleHTTP :: (ToMessage a) => Conf -> ServerPartT IO a -> IO () +simpleHTTP = simpleHTTP' id + +-- | A combination of 'simpleHTTP''' and 'mapServerPartT'. See +-- 'mapServerPartT' for a discussion of the first argument of this +-- function. +-- +-- NOTE: This function always binds to IPv4 ports until Network +-- module is fixed to support IPv6 in a portable way. Use +-- 'simpleHTTPWithSocket' with custom socket if you want different +-- behaviour. +simpleHTTP' :: (ToMessage b, Monad m, Functor m) => (UnWebT m a -> UnWebT IO b) + -> Conf -> ServerPartT m a -> IO () +simpleHTTP' toIO conf hs = + Listen.listen conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req)) + +-- | Generate a result from a 'ServerPartT' and a 'Request'. This is +-- mainly used by CGI (and fast-cgi) wrappers. +simpleHTTP'' :: (ToMessage b, Monad m, Functor m) => ServerPartT m b -> Request -> m Response +simpleHTTP'' hs req = (runWebT $ runServerPartT hs req) >>= (return . (maybe standardNotFound id)) + where + standardNotFound = setHeader "Content-Type" "text/html" $ (toResponse notFoundHtml){rsCode=404} + +-- | Run 'simpleHTTP' with a previously bound socket. Useful if you +-- want to run happstack as user on port 80. Use something like this: +-- +-- > import System.Posix.User (setUserID, UserEntry(..), getUserEntryForName) +-- > +-- > main = do +-- > let conf = nullConf { port = 80 } +-- > socket <- bindPort conf +-- > -- do other stuff as root here +-- > getUserEntryForName "www" >>= setUserID . userID +-- > -- finally start handling incoming requests +-- > tid <- forkIO $ simpleHTTPWithSocket socket Nothing conf impl +-- +-- Note: It's important to use the same conf (or at least the same +-- port) for 'bindPort' and 'simpleHTTPWithSocket'. +-- +-- see also: 'bindPort', 'bindIPv4' +simpleHTTPWithSocket :: (ToMessage a) => Socket -> Conf -> ServerPartT IO a -> IO () +simpleHTTPWithSocket = simpleHTTPWithSocket' id + +-- | Like 'simpleHTTP'' with a socket. +simpleHTTPWithSocket' :: (ToMessage b, Monad m, Functor m) => (UnWebT m a -> UnWebT IO b) + -> Socket -> Conf -> ServerPartT m a -> IO () +simpleHTTPWithSocket' toIO socket conf hs = + Listen.listen' socket conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req)) + +-- | Bind port and return the socket for use with 'simpleHTTPWithSocket'. This +-- function always binds to IPv4 ports until Network module is fixed +-- to support IPv6 in a portable way. +bindPort :: Conf -> IO Socket +bindPort conf = Listen.listenOn (port conf) + +-- | Bind to ip and port and return the socket for use with 'simpleHTTPWithSocket'. +-- +-- > +-- > import Happstack.Server +-- > +-- > main = do let conf = nullConf +-- > addr = "127.0.0.1" +-- > s <- bindIPv4 addr (port conf) +-- > simpleHTTPWithSocket s conf $ ok $ toResponse $ +-- > "now listening on ip addr " ++ addr ++ +-- > " and port " ++ show (port conf) +-- +bindIPv4 :: String -- ^ IP address to bind to (must be an IP address and not a host name) + -> Int -- ^ port number to bind to + -> IO Socket +bindIPv4 addr prt = Listen.listenOnIPv4 addr prt + +-- | Takes your 'WebT', if it is 'mempty' it returns 'Nothing' else it +-- converts the value to a 'Response' and applies your filter to it. +runWebT :: forall m b. (Functor m, ToMessage b) => WebT m b -> m (Maybe Response) +runWebT = (fmap . fmap) appFilterToResp . ununWebT + where + appFilterToResp :: (Either Response b, FilterFun Response) -> Response + appFilterToResp (e, ff) = unFilterFun ff $ either id toResponse e + +notFoundHtml :: String +notFoundHtml = + "" + ++ "Happstack " + ++ ver ++ " File not found" + ++ "

Happstack " ++ ver ++ "

" + ++ "

Your file is not found
" + ++ "To try again is useless
" + ++ "It is just not here

" + ++ "" + where ver = DV.showVersion Cabal.version + + +-- | Wait for a signal. +-- On unix, a signal is sigINT or sigTERM (aka Control-C). +-- +-- On windows, the signal is entering: e +waitForTermination :: IO () +waitForTermination + = do +#ifdef UNIX + istty <- queryTerminal stdInput + mv <- newEmptyMVar + void $ installHandler softwareTermination (CatchOnce (putMVar mv ())) Nothing + void $ installHandler lostConnection (CatchOnce (putMVar mv ())) Nothing + case istty of + True -> void $ installHandler keyboardSignal (CatchOnce (putMVar mv ())) Nothing + False -> return () + takeMVar mv +#else + let loop 'e' = return () + loop _ = getChar >>= loop + loop 'c' +#endif diff --git a/src/Happstack/Server/StdConfig.hs b/src/Happstack/Server/StdConfig.hs deleted file mode 100644 --- a/src/Happstack/Server/StdConfig.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Happstack.Server.StdConfig where - -import Control.Monad.Trans -import Control.Monad -import Happstack.Server.SimpleHTTP -import Happstack.Server.HTTP.FileServe - --- | Is equal to "haskell/Main" -binarylocation :: String -binarylocation = "haskell/Main" - --- | Is equal to "public/log" -loglocation :: String -loglocation = "public/log" - --- | Convenience function around 'errorwrapper' --- with the default binary location set to 'binarylocation' and the --- log location set to 'loglocation'. -errWrap :: (MonadPlus m, FilterMonad Response m, MonadIO m) => m Response -errWrap = errorwrapper binarylocation loglocation ---stateFuns -- main actually has state so you can just import them diff --git a/src/Happstack/Server/Types.hs b/src/Happstack/Server/Types.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Types.hs @@ -0,0 +1,19 @@ +module Happstack.Server.Types + (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..), + takeRequestBody, readInputsBody, + rqURL, mkHeaders, + getHeader, getHeaderBS, getHeaderUnsafe, + hasHeader, hasHeaderBS, hasHeaderUnsafe, + setHeader, setHeaderBS, setHeaderUnsafe, + addHeader, addHeaderBS, addHeaderUnsafe, + setRsCode, -- setCookie, setCookies, + LogAccess, logMAccess, Conf(..), nullConf, result, resultBS, + redirect, -- redirect_, redirect', redirect'_, + isHTTP1_0, isHTTP1_1, + RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength, + HttpVersion(..), Length(..), Method(..), Headers, continueHTTP, + Host, ContentType(..), + readDec', fromReadS, FromReqURI(..) + ) where + +import Happstack.Server.Internal.Types diff --git a/src/Happstack/Server/Validation.hs b/src/Happstack/Server/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Validation.hs @@ -0,0 +1,135 @@ +-- | Support for validating server output on-the-fly. Validators can be configured on a per content-type basis. +module Happstack.Server.Validation where + +import Control.Concurrent (forkIO) +import Control.Exception (evaluate) +import Control.Monad +import Control.Monad.Trans (MonadIO(liftIO)) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as L +import Happstack.Server.Types (Conf(..), Response(..), getHeader, nullConf) +import Happstack.Server.Response (ToMessage, toResponse) +import System.Exit (ExitCode(ExitSuccess, ExitFailure)) +import System.IO (hGetContents, hClose) +import System.Process (runInteractiveProcess, waitForProcess) + +-- | Set the validator which should be used for this particular +-- 'Response' when validation is enabled. +-- +-- Calling this function does not enable validation. That can only be +-- done by enabling the validation in the 'Conf' that is passed to +-- 'simpleHTTP'. +-- +-- You do not need to call this function if the validator set in +-- 'Conf' does what you want already. +-- +-- Example: (use 'noopValidator' instead of the default supplied by +-- 'validateConf') +-- +-- > simpleHTTP validateConf $ ok . setValidator noopValidator =<< htmlPage +-- +-- See also: 'validateConf', 'wdgHTMLValidator', 'noopValidator', +-- 'lazyProcValidator'. +setValidator :: (Response -> IO Response) -> Response -> Response +setValidator v r = r { rsValidator = Just v } + +-- | 'ServerPart' version of 'setValidator'. +-- +-- Example: (Set validator to 'noopValidator') +-- +-- > simpleHTTP validateConf $ setValidatorSP noopValidator (dir "ajax" ... ) +-- +setValidatorSP :: (Monad m, ToMessage r) => (Response -> IO Response) -> m r -> m Response +setValidatorSP v sp = return . setValidator v . toResponse =<< sp + +-- | Extend 'nullConf' by enabling validation and setting +-- 'wdgHTMLValidator' as the default validator for @text\/html@. +-- +-- Example: +-- +-- > simpleHTTP validateConf . anyRequest $ ok htmlPage +-- +validateConf :: Conf +validateConf = nullConf { validator = Just wdgHTMLValidator } + +-- | Actually perform the validation on a 'Response'. +-- +-- Run the validator specified in the 'Response'. If none is provide +-- use the supplied default instead. +-- +-- Note: This function will run validation unconditionally. You +-- probably want 'setValidator' or 'validateConf'. +runValidator :: (Response -> IO Response) -> Response -> IO Response +runValidator defaultValidator r = + case rsValidator r of + Nothing -> defaultValidator r + (Just altValidator) -> altValidator r + +-- | Validate @text\/html@ content with @WDG HTML Validator@. +-- +-- This function expects the executable to be named @validate@ and it +-- must be in the default @PATH@. +-- +-- See also: 'setValidator', 'validateConf', 'lazyProcValidator'. +wdgHTMLValidator :: (MonadIO m, ToMessage r) => r -> m Response +wdgHTMLValidator = liftIO . lazyProcValidator "validate" ["-w","--verbose","--charset=utf-8"] Nothing Nothing handledContentTypes . toResponse + where + handledContentTypes (Just ct) = elem (takeWhile (\c -> c /= ';' && c /= ' ') (B.unpack ct)) [ "text/html", "application/xhtml+xml" ] + handledContentTypes Nothing = False + +-- | A validator which always succeeds. +-- +-- Useful for selectively disabling validation. For example, if you +-- are sending down HTML fragments to an AJAX application and the +-- default validator only understands complete documents. +noopValidator :: Response -> IO Response +noopValidator = return + +-- | Validate the 'Response' using an external application. +-- +-- If the external application returns 0, the original response is +-- returned unmodified. If the external application returns non-zero, +-- a 'Response' containing the error messages and original response +-- body is returned instead. +-- +-- This function also takes a predicate filter which is applied to the +-- content-type of the response. The filter will only be applied if +-- the predicate returns true. +-- +-- NOTE: This function requires the use of -threaded to avoid +-- blocking. However, you probably need that for Happstack anyway. +-- +-- See also: 'wdgHTMLValidator'. +lazyProcValidator :: FilePath -- ^ name of executable + -> [String] -- ^ arguments to pass to the executable + -> Maybe FilePath -- ^ optional path to working directory + -> Maybe [(String, String)] -- ^ optional environment (otherwise inherit) + -> (Maybe B.ByteString -> Bool) -- ^ content-type filter + -> Response -- ^ Response to validate + -> IO Response +lazyProcValidator exec args wd env mimeTypePred response + | mimeTypePred (getHeader "content-type" response) = + do (inh, outh, errh, ph) <- runInteractiveProcess exec args wd env + out <- hGetContents outh + err <- hGetContents errh + void $ forkIO $ do L.hPut inh (rsBody response) + hClose inh + void $ forkIO $ evaluate (length out) >> return () + void $ forkIO $ evaluate (length err) >> return () + ec <- waitForProcess ph + case ec of + ExitSuccess -> return response + (ExitFailure _) -> + return $ toResponse (unlines ([ "ExitCode: " ++ show ec + , "stdout:" + , out + , "stderr:" + , err + , "input:" + ] ++ + showLines (rsBody response))) + | otherwise = return response + where + column = " " ++ (take 120 $ concatMap (\n -> " " ++ show n) (drop 1 $ cycle [0..9::Int])) + showLines :: L.ByteString -> [String] + showLines string = column : zipWith (\n -> \l -> show n ++ " " ++ (L.unpack l)) [1::Integer ..] (L.lines string) diff --git a/src/Happstack/Server/XSLT.hs b/src/Happstack/Server/XSLT.hs deleted file mode 100644 --- a/src/Happstack/Server/XSLT.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE TemplateHaskell, FlexibleInstances , UndecidableInstances, - DeriveDataTypeable, MultiParamTypeClasses, CPP, ScopedTypeVariables, - PatternSignatures #-} -module Happstack.Server.XSLT - (xsltFile, xsltString, xsltElem, xsltFPS, xsltFPSIO, XSLPath, - xsltproc,saxon,procFPSIO,procLBSIO,XSLTCommand,XSLTCmd - ) where - - -import System.Log.Logger - -import Happstack.Server.MinHaXML -import Happstack.Util.Common(runCommand) -import Control.Exception.Extensible(bracket,try,SomeException) -import qualified Data.ByteString.Char8 as P -import qualified Data.ByteString.Lazy.Char8 as L -import System.Directory(removeFile) -import System.Environment(getEnv) -import System.IO -import System.IO.Unsafe(unsafePerformIO) -import Text.XML.HaXml.Verbatim(verbatim) -import Happstack.Data hiding (Element) - -logMX :: Priority -> String -> IO () -logMX = logM "Happstack.Server.XSLT" - -type XSLPath = FilePath - -$(deriveAll [''Show,''Read,''Default, ''Eq, ''Ord] - [d| - data XSLTCmd = XSLTProc | Saxon - |] - ) - -xsltCmd :: XSLTCmd - -> XSLPath - -> FilePath - -> FilePath - -> (FilePath, [String]) -xsltCmd XSLTProc = xsltproc' -xsltCmd Saxon = saxon' - --- | Uses 'xsltString' to transform the given XML 'Element' into a --- a 'String'. -xsltElem :: XSLPath -> Element -> String -xsltElem xsl = xsltString xsl . verbatim - - -procLBSIO :: XSLTCmd -> XSLPath -> L.ByteString -> IO L.ByteString -procLBSIO xsltp' xsl inp = - withTempFile "happs-src.xml" $ \sfp sh -> do - withTempFile "happs-dst.xml" $ \dfp dh -> do - let xsltp = xsltCmd xsltp' - L.hPut sh inp - hClose sh - hClose dh - xsltFileEx xsltp xsl sfp dfp - s <- L.readFile dfp - logMX DEBUG (">>> XSLT: result: "++ show s) - return s - - -procFPSIO :: XSLTCommand - -> XSLPath - -> [P.ByteString] - -> IO [P.ByteString] -procFPSIO xsltp xsl inp = - withTempFile "happs-src.xml" $ \sfp sh -> do - withTempFile "happs-dst.xml" $ \dfp dh -> do - mapM_ (P.hPut sh) inp - hClose sh - hClose dh - xsltFileEx xsltp xsl sfp dfp - s <- P.readFile dfp - logMX DEBUG (">>> XSLT: result: "++ show s) - return [s] - --- | Performs an XSL transformation with lists of ByteStrings instead of --- a String. -xsltFPS :: XSLPath -> [P.ByteString] -> [P.ByteString] -xsltFPS xsl = unsafePerformIO . xsltFPSIO xsl - --- | Equivalent to 'xsltFPS' but does not hide the inherent IO of the low-level --- ByteString operations. -xsltFPSIO :: XSLPath -> [P.ByteString] -> IO [P.ByteString] -xsltFPSIO xsl inp = - withTempFile "happs-src.xml" $ \sfp sh -> do - withTempFile "happs-dst.xml" $ \dfp dh -> do - mapM_ (P.hPut sh) inp - hClose sh - hClose dh - xsltFile xsl sfp dfp - s <- P.readFile dfp - logMX DEBUG (">>> XSLT: result: "++ show s) - return [s] - --- | Uses the provided xsl file to transform the given string. --- This function creates temporary files during its execution, but --- guarantees their cleanup. -xsltString :: XSLPath -> String -> String -xsltString xsl inp = unsafePerformIO $ - withTempFile "happs-src.xml" $ \sfp sh -> do - withTempFile "happs-dst.xml" $ \dfp dh -> do - hPutStr sh inp - hClose sh - hClose dh - xsltFile xsl sfp dfp - s <- readFileStrict dfp - logMX DEBUG (">>> XSLT: result: "++ show s) - return s - --- | Note that the xsl file must have .xsl suffix. -xsltFile :: XSLPath -> FilePath -> FilePath -> IO () -xsltFile = xsltFileEx xsltproc' - --- | Use @xsltproc@ to transform XML. -xsltproc :: XSLTCmd -xsltproc = XSLTProc -xsltproc' :: XSLTCommand -xsltproc' dst xsl src = ("xsltproc",["-o",dst,xsl,src]) - - --- | Use @saxon@ to transform XML. -saxon :: XSLTCmd -saxon = Saxon -saxon' :: XSLTCommand -saxon' dst xsl src = ("java -classpath /usr/share/java/saxon.jar", - ["com.icl.saxon.StyleSheet" - ,"-o",dst,src,xsl]) - -type XSLTCommand = XSLPath -> FilePath -> FilePath -> (FilePath,[String]) -xsltFileEx :: XSLTCommand -> XSLPath -> FilePath -> FilePath -> IO () -xsltFileEx xsltp xsl src dst = do - let msg = (">>> XSLT: Starting xsltproc " ++ unwords ["-o",dst,xsl,src]) - logMX DEBUG msg - uncurry runCommand $ xsltp dst xsl src - logMX DEBUG (">>> XSLT: xsltproc done") - --- Utilities - -withTempFile :: String -> (FilePath -> Handle -> IO a) -> IO a -withTempFile str hand = bracket (openTempFile tempDir str) (removeFile . fst) (uncurry hand) - -readFileStrict :: FilePath -> IO String -readFileStrict fp = do - let fseqM [] = return [] - fseqM xs = last xs `seq` return xs - fseqM =<< readFile fp - -{-# NOINLINE tempDir #-} -tempDir :: FilePath -tempDir = unsafePerformIO $ tryAny [getEnv "TEMP",getEnv "TMP"] err - where err = return "/tmp" - -tryAny :: [IO a] -> IO a -> IO a -tryAny [] c = c -tryAny (x:xs) c = either (\(_::SomeException) -> tryAny xs c) return =<< try x 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 @@ -1,41 +1,262 @@ -- |HUnit tests and QuickQuick properties for Happstack.Server.* module Happstack.Server.Tests (allTests) where -import Test.HUnit as HU (Test(..),(~:),(~?),(@?=)) +import qualified Codec.Compression.GZip as GZ +import qualified Codec.Compression.Zlib as Z +import Control.Arrow ((&&&)) +import Control.Applicative ((<$>)) +import Control.Concurrent.MVar +import Control.Monad +import Data.ByteString.Lazy.Char8 (pack, unpack) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as L +import Data.List (intercalate) +import qualified Data.Map as Map +import Happstack.Server ( Request(..), Method(..), Response(..), ServerPart, Headers, RqBody(Body), HttpVersion(..) + , ToMessage(..), HeaderPair(..), ok, dir, simpleHTTP'', composeFilter, noContentLength, matchMethod + , look, getDataFn) +import Happstack.Server.FileServe.BuildingBlocks (sendFileResponse) import Happstack.Server.Cookie -import Happstack.Server.Parts +import Happstack.Server.Internal.Compression +import Happstack.Server.Internal.Cookie +import Happstack.Server.Internal.Multipart +import Happstack.Server.Internal.MessageWrap +import Happstack.Server.Internal.RFC822Headers (ContentDisposition(..), parseContentDisposition) +import Happstack.Server.SURI(ToSURI(..), path, query) +import Test.HUnit as HU (Test(..), (~:), (@?=), (@=?), assertEqual) import Text.ParserCombinators.Parsec --- |All of the tests for happstack-util should be listed here. +-- |All of the tests for happstack-util should be listed here. allTests :: Test -allTests = - "happstack-server tests" ~: [cookieParserTest, acceptEncodingParserTest] +allTests = + "happstack-server tests" ~: [ cookieParserTest + , acceptEncodingParserTest + , multipart + , compressFilterResponseTest + , matchMethodTest + , cookieHeaderOrderTest + , pContentDispositionFilename + , applicativeTest + ] cookieParserTest :: Test -cookieParserTest = +cookieParserTest = "cookieParserTest" ~: [parseCookies "$Version=1;Cookie1=value1;$Path=\"/testpath\";$Domain=example.com;cookie2=value2" @?= (Right [ - Cookie "1" "/testpath" "example.com" "cookie1" "value1" - , Cookie "1" "" "" "cookie2" "value2" + 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!@#%^&*()-_+={}[]:;'<>,.?/\\|" + Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/|" False False SameSiteNoValue False ]) ,parseCookies " cookie1 = value1 " @?= (Right [ - Cookie "" "" "" "cookie1" "value1" + Cookie "" "" "" "cookie1" "value1" False False SameSiteNoValue False ]) ,parseCookies " $Version=\"1\";buggygooglecookie = valuewith=whereitshouldnotbe " @?= (Right [ - Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" + Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" False False SameSiteNoValue False ]) + , parseCookies "foo=\"\\\"bar\\\"\"" + @?= (Right [ + Cookie "" "" "" "foo" "\"bar\"" False False SameSiteNoValue False + ]) ] acceptEncodingParserTest :: Test acceptEncodingParserTest = "acceptEncodingParserTest" ~: - [either (Left . show) Right (parse encodings "" " gzip;q=1,*, compress ; q = 0.5 ") - @?= (Right [("gzip", Just 1),("*", Nothing),("compress", Just 0.5)]) + map (\(str, result) -> either (Left . show) Right (parse encodings "" str) @?= (Right result)) acceptEncodings + where + acceptEncodings = + [ (" gzip;q=1,*, compress ; q = 0.5 ", [("gzip", Just 1),("*", Nothing),("compress", Just 0.5)]) + , (" compress , gzip", [ ("compress", Nothing), ("gzip", Nothing)]) + , (" ", []) + , (" *", [("*", Nothing)]) + , (" compress;q=0.5, gzip;q=1.0", [("compress", Just 0.5), ("gzip", Just 1.0)]) + , (" gzip;q=1.0, identity; q=0.5, *;q=0", [("gzip", Just 1.0), ("identity",Just 0.5), ("*", Just 0)]) + , (" x-gzip",[("x-gzip", Nothing)]) + ] + +multipart :: Test +multipart = + "split multipart" ~: + [ ([BodyPart (pack "content-type: text/plain\r\n") (pack "1")], Nothing) @=? + parseMultipartBody (pack "boundary") + (pack "--boundary\r\ncontent-type: text/plain\r\n\r\n1\r\n--boundary--\r\nend") + + , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1")], Nothing) @=? + parseMultipartBody (pack "boundary.with.dot") + (pack "--boundary.with.dot\r\ncontent-type: text/plain\r\n\r\n1\r\n--boundary.with.dot--\r\nend") + + , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1")], Nothing) @=? + parseMultipartBody (pack "boundary") + (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\r\n--boundary--\r\nend") + + , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1\n")], Nothing) @=? + parseMultipartBody (pack "boundary") + (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\n\r\n--boundary--\r\nend") + + , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1\r\n")], Nothing) @=? + parseMultipartBody (pack "boundary") + (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\r\n\r\n--boundary--\r\nend") + , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1\n\r")], Nothing) @=? + parseMultipartBody (pack "boundary") + (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\n\r\r\n--boundary--\r\nend") + + , ([BodyPart (pack "content-type: text/plain\r\n") (pack "\r\n1\n\r")], Nothing) @=? + parseMultipartBody (pack "boundary") + (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n\r\n1\n\r\r\n--boundary--\r\nend") ] + +compressFilterResponseTest :: Test +compressFilterResponseTest = + "compressFilterResponseTest" ~: + [ uncompressedResponse + , uncompressedSendFile + , compressedResponseGZ + , compressedResponseZ + , compressedSendFile + , compressedSendFileNoIdentity + ] + +mkRequest :: Method -> String -> [(String, Cookie)] -> Headers -> L.ByteString -> IO Request +mkRequest method uri cookies headers body = + do let u = toSURI uri + ib <- newEmptyMVar + b <- newMVar (Body body) + return $ Request { rqMethod = method + , rqPaths = (pathEls (path u)) + , rqUri = (path u) + , rqQuery = (query u) + , rqInputsQuery = (queryInput u) + , rqInputsBody = ib + , rqCookies = cookies + , rqVersion = HttpVersion 1 1 + , rqHeaders = headers + , rqBody = b + , rqPeer = ("",0) + , rqSecure = False + } + +compressPart :: ServerPart Response +compressPart = + do void compressedResponseFilter + composeFilter noContentLength + msum [ dir "response" $ ok (toResponse "compress Response") + , dir "sendfile" $ ok (sendFileResponse "text/plain" "/dev/null" Nothing 0 100) + ] + +cookieHeaderOrderTestHandler :: ServerPart Response +cookieHeaderOrderTestHandler = do + expireCookie "thecookie" + addCookie Session $ mkCookie "thecookie" "value" + ok $ toResponse $ "works" + +cookieHeaderOrderTest :: Test +cookieHeaderOrderTest = + "cookie header order test" ~: + do req <- mkRequest GET "/" [] Map.empty L.empty + res <- simpleHTTP'' cookieHeaderOrderTestHandler req + let Just pair = (Map.lookup (B.pack "set-cookie") (rsHeaders res)) + assertEqual "Add cookie wins" False $ B.isInfixOf (B.pack "Max-Age=0") + (last $ hValue pair) + +uncompressedResponse :: Test +uncompressedResponse = + "uncompressedResponse" ~: + do req <- mkRequest GET "/response" [] Map.empty L.empty + res <- simpleHTTP'' compressPart req + assertEqual "respone code" (rsCode res) 200 + assertEqual "body" (unpack (rsBody res)) "compress Response" + assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing + +uncompressedSendFile :: Test +uncompressedSendFile = + "uncompressedSendFile" ~: + do req <- mkRequest GET "/sendfile" [] Map.empty L.empty + res <- simpleHTTP'' compressPart req + assertEqual "respone code" (rsCode res) 200 + assertEqual "filepath" (sfFilePath res) "/dev/null" + assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing + +compressedResponseGZ :: Test +compressedResponseGZ = + "compressedResponseGZ" ~: + do req <- mkRequest GET "/response" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1"])) L.empty + res <- simpleHTTP'' compressPart req + assertEqual "respone code" (rsCode res) 200 + assertEqual "body" (unpack (GZ.decompress (rsBody res))) ("compress Response") + assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) (Just (B.pack "Content-Encoding", [B.pack "gzip"])) + +compressedResponseZ :: Test +compressedResponseZ = + "compressedResponseZ" ~: + do req <- mkRequest GET "/response" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " deflate;q=1"])) L.empty + res <- simpleHTTP'' compressPart req + assertEqual "respone code" (rsCode res) 200 + assertEqual "body" (unpack (Z.decompress (rsBody res))) ("compress Response") + assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) (Just (B.pack "Content-Encoding", [B.pack "deflate"])) + +compressedSendFile :: Test +compressedSendFile = + "compressedSendfile" ~: + do req <- mkRequest GET "/sendfile" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1"])) L.empty + res <- simpleHTTP'' compressPart req + assertEqual "respone code" (rsCode res) 200 + assertEqual "filepath" (sfFilePath res) "/dev/null" + assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing + +compressedSendFileNoIdentity :: Test +compressedSendFileNoIdentity = + "compressedSendFileNoIdentity" ~: + do req <- mkRequest GET "/sendfile" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1, identity: q=0.0"])) L.empty + res <- simpleHTTP'' compressPart req + assertEqual "respone code" (rsCode res) 406 + assertEqual "body" (unpack (rsBody res)) "" + assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing + +matchMethodTest :: Test +matchMethodTest = + "matchMethodTest" ~: + do forM_ gethead $ \m -> matchMethod GET m @?= True + forM_ others $ \m -> matchMethod GET m @?= False + forM_ gethead $ \m -> matchMethod [GET] m @?= True + forM_ others $ \m -> matchMethod [GET] m @?= False + forM_ gethead $ \m -> matchMethod [GET, HEAD] m @?= True + forM_ others $ \m -> matchMethod [GET, HEAD] m @?= False + matchMethod POST GET @?= False + matchMethod POST HEAD @?= False + matchMethod POST TRACE @?= False + matchMethod POST POST @?= True + matchMethod [POST, PUT] GET @?= False + matchMethod [POST, PUT] HEAD @?= False + matchMethod [POST, PUT] TRACE @?= False + matchMethod [POST, PUT] POST @?= True + matchMethod [POST, PUT] PUT @?= True + forM_ (others) $ \m -> matchMethod (`notElem` gethead) m @?= True + forM_ (gethead ++ others) $ \m -> matchMethod () m @?= True + where + gethead = [GET, HEAD] + others = [POST, PUT, DELETE, TRACE, OPTIONS, CONNECT] + + +-- | https://github.com/Happstack/happstack-server/pull/56 +pContentDispositionFilename :: Test +pContentDispositionFilename = + "pContentDispositionFilename" ~: + do let doesNotWorkWithOldParserButWithNew = "form-data; filename=\"file.pdf\"; name=\"file\"" :: String + c <- parseContentDisposition doesNotWorkWithOldParserButWithNew + assertEqual "parseContentDisposition" c (ContentDisposition "form-data" [("filename","file.pdf"),("name","file")]) + +applicativeTest :: Test +applicativeTest = + "applicativeTest" ~: + do req <- mkRequest GET "/response" [] mempty L.empty + res <- flip simpleHTTP'' req $ do + Left errors <- getDataFn $ (++) <$> look "a" <*> look "b" + pure $ intercalate "," errors + let ref = "Parameter not found: a,Parameter not found: b" + assertEqual "getDataFn/ReaderError doesn't short-circuit" ref (unpack (rsBody res)) diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -16,4 +16,4 @@ return c case (failures c) + (errors c) of 0 -> return () - n -> exitFailure + _ -> exitFailure