happstack-server-7.4.6.2/0000755000000000000000000000000012725110331013333 5ustar0000000000000000happstack-server-7.4.6.2/COPYING0000644000000000000000000000267112725110331014374 0ustar0000000000000000Copyright (c) 2006, HAppS.org All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of the HAppS.org; nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. happstack-server-7.4.6.2/happstack-server.cabal0000644000000000000000000001405412725110331017605 0ustar0000000000000000Name: happstack-server Version: 7.4.6.2 Synopsis: Web related tools and services. Description: Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course License: BSD3 License-file: COPYING Author: Happstack team, HAppS LLC Maintainer: Happstack team homepage: http://happstack.com Category: Web, Happstack Build-Type: Simple Cabal-Version: >= 1.8 Extra-Source-Files: tests/Happstack/Server/Tests.hs README.md tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC==8.0.1 source-repository head type: git location: https://github.com/Happstack/happstack-server.git Flag template_haskell Description: Template Haskell is available on this system Default: True Manual: True flag network-uri description: Get Network.URI from the network-uri package default: True Library Exposed-modules: Happstack.Server Happstack.Server.Auth Happstack.Server.Cookie Happstack.Server.Compression Happstack.Server.Client Happstack.Server.Error Happstack.Server.FileServe Happstack.Server.FileServe.BuildingBlocks 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.Socket Happstack.Server.Internal.TimeoutIO Happstack.Server.Internal.TimeoutManager Happstack.Server.Internal.TimeoutSocket Happstack.Server.Internal.Monads Happstack.Server.Monads Happstack.Server.Proxy Happstack.Server.Response Happstack.Server.Routing Happstack.Server.RqData Happstack.Server.SURI Happstack.Server.SimpleHTTP Happstack.Server.Types Happstack.Server.Validation Other-modules: Happstack.Server.Internal.Clock Happstack.Server.Internal.LazyLiner Happstack.Server.Internal.RFC822Headers Happstack.Server.Internal.SocketTH Happstack.Server.SURI.ParseURI Paths_happstack_server if flag(network-uri) build-depends: network > 2.6 && < 2.7, network-uri >= 2.6 && < 2.7 else build-depends: network < 2.6 Build-Depends: base >= 4 && < 5, base64-bytestring == 1.0.*, blaze-html >= 0.5 && < 0.9, bytestring, containers, directory, exceptions, extensible-exceptions, filepath, hslogger >= 1.0.2, html, monad-control >= 0.3 && < 1.1, mtl >= 2 && < 2.3, old-locale, parsec < 4, process, sendfile >= 0.7.1 && < 0.8, system-filepath >= 0.3.1, syb, text >= 0.10 && < 1.3, time, time-compat, threads >= 0.5, transformers >= 0.1.3 && < 0.6, transformers-base >= 0.4 && < 0.5, transformers-compat >= 0.3 && < 0.6, utf8-string >= 0.3.4 && < 1.1, xhtml, zlib if (flag(template_haskell) && !(arch(arm))) Build-Depends: template-haskell cpp-options: -DTEMPLATE_HASKELL hs-source-dirs: src if !os(windows) Build-Depends: unix cpp-options: -DUNIX Extensions: TemplateHaskell, DeriveDataTypeable, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, OverlappingInstances, FlexibleInstances, UndecidableInstances, ScopedTypeVariables, TypeSynonymInstances, PatternGuards CPP, ForeignFunctionInterface ghc-options: -Wall -fwarn-tabs GHC-Prof-Options: -auto-all -- The policy is to support GHC versions no older than the GHC stable -- branch that was used by the latest Haskell Platform release -- available 18 months ago. In order to avoid people spending time -- keeping the build working for older versions, we tell Cabal that -- it shouldn't allow builds with them. if impl(ghc < 7.0) buildable: False Test-Suite happstack-server-tests Type: exitcode-stdio-1.0 Main-Is: Test.hs GHC-Options: -threaded hs-source-dirs: tests Build-depends: HUnit, base, bytestring, containers, happstack-server, parsec < 4, zlib happstack-server-7.4.6.2/README.md0000644000000000000000000000145512725110331014617 0ustar0000000000000000# happstack-server [![Hackage Status](https://img.shields.io/hackage/v/happstack-server.svg)][hackage] [![Build Status](https://travis-ci.org/Happstack/happstack-server.svg?branch=master)](https://travis-ci.org/Happstack/happstack-server) [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]. happstack-server-7.4.6.2/Setup.hs0000644000000000000000000000014112725110331014763 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMainWithHooks simpleUserHooks happstack-server-7.4.6.2/src/0000755000000000000000000000000012725110331014122 5ustar0000000000000000happstack-server-7.4.6.2/src/Happstack/0000755000000000000000000000000012725110331016040 5ustar0000000000000000happstack-server-7.4.6.2/src/Happstack/Server.hs0000644000000000000000000000711212725110331017643 0ustar0000000000000000{- | 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 -- * Proxying , module Happstack.Server.Proxy -- * Output Validation , module Happstack.Server.Validation -- * HTTP Types , module Happstack.Server.Types -- * Other , module Happstack.Server.Client -- , module Happstack.Server.Internal.Monads ) where import Happstack.Server.Client import Happstack.Server.SimpleHTTP (simpleHTTP , simpleHTTP' , simpleHTTP'' , 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.Proxy import Happstack.Server.RqData import Happstack.Server.Validation import Happstack.Server.Types -- import Happstack.Server.Internal.Monadshappstack-server-7.4.6.2/src/Happstack/Server/0000755000000000000000000000000012725110331017306 5ustar0000000000000000happstack-server-7.4.6.2/src/Happstack/Server/Auth.hs0000644000000000000000000000371112725110331020545 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | Support for basic access authentication module Happstack.Server.Auth where import Control.Monad (MonadPlus(mzero, mplus)) import Data.ByteString.Base64 as Base64 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 xs = basicAuthImpl `mplus` xs where basicAuthImpl = do aHeader <- getHeaderM "authorization" case aHeader of Nothing -> err Just x -> do r <- parseHeader x case r of (name, ':':password) | validLogin name password -> mzero | otherwise -> err _ -> err validLogin name password = M.lookup name authMap == Just password parseHeader h = case Base64.decode . B.drop 6 $ h of (Left _) -> err (Right bs) -> return (break (':'==) (B.unpack bs)) headerName = "WWW-Authenticate" headerValue = "Basic realm=\"" ++ realmName ++ "\"" err :: (Happstack m) => m a err = escape $ do setHeaderM headerName headerValue unauthorized $ toResponse "Not authorized" happstack-server-7.4.6.2/src/Happstack/Server/Client.hs0000644000000000000000000000245112725110331021062 0ustar0000000000000000-- | a very simple interface for acting as an HTTP client. This is mostly used for things like "Happstack.Server.Proxy". You are more likely to want a library like http-enumerator . module Happstack.Server.Client where import Happstack.Server.Internal.Handler (parseResponse, putRequest) import Happstack.Server.Internal.Types (Response, Request, getHeader, readDec') import Data.Maybe (fromJust) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L import Network (PortID(PortNumber), connectTo, withSocketsDo) import System.IO (BufferMode(NoBuffering), hFlush, hSetBuffering) -- | Sends the serialized request to the host defined in the request -- and attempts to parse response upon arrival. getResponse :: Request -> IO (Either String Response) getResponse rq = withSocketsDo $ do let (hostName,p) = span (/=':') $ fromJust $ fmap B.unpack $ getHeader "host" rq portInt = if null p then 80 else readDec' $ tail p portId = PortNumber $ toEnum $ portInt h <- connectTo hostName portId hSetBuffering h NoBuffering putRequest h rq hFlush h inputStr <- L.hGetContents h return $ parseResponse inputStr happstack-server-7.4.6.2/src/Happstack/Server/Compression.hs0000644000000000000000000000163312725110331022146 0ustar0000000000000000{-# 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 ) happstack-server-7.4.6.2/src/Happstack/Server/Cookie.hs0000644000000000000000000000312712725110331021056 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} -- | Functions for creating, adding, and expiring cookies. To lookup cookie values see "Happstack.Server.RqData". module Happstack.Server.Cookie ( Cookie(..) , CookieLife(..) , mkCookie , addCookie , addCookies , expireCookie ) where import Control.Monad.Trans (MonadIO(..)) import Happstack.Server.Internal.Monads (FilterMonad, composeFilter) import Happstack.Server.Internal.Cookie (Cookie(..), CookieLife(..), calcLife, mkCookie, mkCookieHeader) import Happstack.Server.Types (Response, addHeader) -- | Add the 'Cookie' to 'Response'. -- -- example -- -- > main = simpleHTTP nullConf $ -- > do addCookie Session (mkCookie "name" "value") -- > ok $ "You now have a session cookie." -- -- 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 -- | Add the list 'Cookie' to the 'Response'. -- -- see also: 'addCookie' addCookies :: (MonadIO m, FilterMonad Response m) => [(CookieLife, Cookie)] -> m () addCookies = mapM_ (uncurry addCookie) -- | 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 "") happstack-server-7.4.6.2/src/Happstack/Server/Error.hs0000644000000000000000000000526712725110331020745 0ustar0000000000000000-- | Some useful functions if you want to wrap the 'ServerPartT' monad transformer around the 'ErrorT' monad transformer. e.g., @'ServerPartT' ('ErrorT' e m) a@. This allows you to use 'throwError' and 'catchError' inside your monad. module Happstack.Server.Error where import Control.Monad.Error (Error, ErrorT(runErrorT)) import 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 (ErrorT e m) a -> UnWebT m a spUnwrapErrorT handler rq = \x -> do err <- runErrorT 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, 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" #-} happstack-server-7.4.6.2/src/Happstack/Server/FileServe.hs0000644000000000000000000000070612725110331021531 0ustar0000000000000000-- | 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 happstack-server-7.4.6.2/src/Happstack/Server/I18N.hs0000644000000000000000000000400412725110331020317 0ustar0000000000000000module Happstack.Server.I18N ( acceptLanguage , bestLanguage ) where import Control.Applicative ((<$>)) 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) happstack-server-7.4.6.2/src/Happstack/Server/Monads.hs0000644000000000000000000001121412725110331021062 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | 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 ) where import Control.Applicative (Alternative, Applicative) import Control.Monad (MonadPlus(mzero)) import Control.Monad.Error (Error, ErrorT) 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) instance (Happstack m, Error e) => Happstack (ErrorT e m) 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 happstack-server-7.4.6.2/src/Happstack/Server/Proxy.hs0000644000000000000000000000752212725110331020771 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- |Support for creating a proxy or reverse-proxy server module Happstack.Server.Proxy where import Control.Monad (MonadPlus(mzero), liftM) import Control.Monad.Trans (MonadIO(liftIO)) import qualified Data.ByteString.Char8 as B import Data.List (isPrefixOf) import Data.Maybe (fromJust, fromMaybe) import Happstack.Server.Monads (ServerMonad(askRq), FilterMonad, WebMonad, escape') import Happstack.Server.Response (badGateway, toResponse) import Happstack.Server.Client (getResponse) import Happstack.Server.Types (Request(rqPaths, rqHeaders, rqPeer), Response, setHeader, getHeader) -- | 'proxyServe' is for creating a part that acts as a proxy. The -- sole argument @['String']@ is a list of allowed domains for -- proxying. This matches the domain part of the request and the -- wildcard * can be used. E.g. -- -- * \"*\" to match anything. -- -- * \"*.example.com\" to match anything under example.com -- -- * \"example.com\" to match just example.com -- -- -- TODO: annoyingly enough, this method eventually calls 'escape', so -- any headers you set won't be used, and the computation immediately -- ends. proxyServe :: (MonadIO m, WebMonad Response m, ServerMonad m, MonadPlus m, FilterMonad Response m) => [String] -> m Response proxyServe allowed = do rq <- askRq if cond rq then proxyServe' rq else mzero where cond rq | "*" `elem` allowed = True | domain `elem` allowed = True | superdomain `elem` wildcards =True | otherwise = False where domain = head (rqPaths rq) superdomain = tail $ snd $ break (=='.') domain wildcards = (map (drop 2) $ filter ("*." `isPrefixOf`) allowed) -- | Take a proxy 'Request' and create a 'Response'. Your basic proxy -- building block. See 'unproxify'. -- -- TODO: this would be more useful if it didn\'t call 'escape' -- (e.g. it let you modify the response afterwards, or set additional -- headers) proxyServe' :: (MonadIO m, FilterMonad Response m, WebMonad Response m) => Request-> m Response proxyServe' rq = liftIO (getResponse (unproxify rq)) >>= either (badGateway . toResponse . show) escape' -- | This is a reverse proxy implementation. See 'unrproxify'. -- -- TODO: this would be more useful if it didn\'t call 'escape', just -- like 'proxyServe''. rproxyServe :: (ServerMonad m, WebMonad Response m, FilterMonad Response m, MonadIO m) => String -- ^ defaultHost -> [(String, String)] -- ^ map to look up hostname mappings. For the reverse proxy -> m Response -- ^ the result is a 'ServerPartT' that will reverse proxy for you. rproxyServe defaultHost list = do rq <- askRq r <- liftIO (getResponse (unrproxify defaultHost list rq)) either (badGateway . toResponse . show) (escape') r unproxify :: Request -> Request unproxify rq = rq {rqPaths = tail $ rqPaths rq, rqHeaders = forwardedFor $ forwardedHost $ setHeader "host" (head $ rqPaths rq) $ rqHeaders rq} where appendInfo hdr val = setHeader hdr (csv val $ maybe "" B.unpack $ getHeader hdr rq) forwardedFor = appendInfo "X-Forwarded-For" (fst $ rqPeer rq) forwardedHost = appendInfo "X-Forwarded-Host" (B.unpack $ fromJust $ getHeader "host" rq) csv v "" = v csv v x = x++", " ++ v unrproxify :: String -> [(String, String)] -> Request -> Request unrproxify defaultHost list rq = let host::String host = fromMaybe defaultHost $ flip lookup list =<< B.unpack `liftM` getHeader "host" rq newrq = rq {rqPaths = host: rqPaths rq} in unproxify newrq happstack-server-7.4.6.2/src/Happstack/Server/Response.hs0000644000000000000000000003161612725110331021447 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances, ScopedTypeVariables #-} -- | Functions and classes related to generating a 'Response' and setting the response code. For detailed instruction see the Happstack Crash Course: module Happstack.Server.Response ( -- * 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 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 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) #if MIN_VERSION_time(1,5,0) import Data.Time (UTCTime, formatTime, defaultTimeLocale) #else import Data.Time (UTCTime, formatTime) import System.Locale (defaultTimeLocale) #endif -- | 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" toMessage = LU.fromString . XHtml.renderHtml 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) happstack-server-7.4.6.2/src/Happstack/Server/Routing.hs0000644000000000000000000002027512725110331021277 0ustar0000000000000000{-# 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 methodOnly [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)) /= '/' happstack-server-7.4.6.2/src/Happstack/Server/RqData.hs0000644000000000000000000006222412725110331021024 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} -- | 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)) 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) import Control.Monad.Error (Error(noMsg, strMsg), ErrorT, mapErrorT) import Control.Monad.Trans (MonadIO(..), lift) import Control.Monad.Trans.Except (ExceptT, mapExceptT) import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.UTF8 as LU import Data.Char (toLower) import Data.Either (partitionEithers) import Data.Generics (Data, Typeable) import Data.Maybe (fromJust) import Data.Monoid (Monoid(mempty, mappend, mconcat)) 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) newtype ReaderError r e a = ReaderError { unReaderError :: ReaderT r (Either e) a } deriving (Functor, Monad, MonadPlus) instance (Error e, Monoid e) => MonadReader r (ReaderError r e) where ask = ReaderError ask local f m = ReaderError $ local f (unReaderError m) instance (Monoid e, Error e) => Applicative (ReaderError r e) where pure = return (ReaderError (ReaderT f)) <*> (ReaderError (ReaderT a)) = ReaderError $ ReaderT $ \env -> (f env) `apEither` (a env) instance (Monoid e, Error e) => Alternative (ReaderError r e) where 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, Typeable) instance Monoid (Errors a) where mempty = Errors [] (Errors x) `mappend` (Errors y) = Errors (x ++ y) mconcat errs = Errors $ concatMap unErrors errs instance Error (Errors String) where noMsg = Errors [] strMsg str = Errors [str] {- 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) instance (Monad m, Error e, HasRqData m) => HasRqData (ErrorT e m) where askRqEnv = lift askRqEnv localRqEnv f = mapErrorT (localRqEnv f) rqDataError e = lift (rqDataError e) 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 -- | 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 happstack-server-7.4.6.2/src/Happstack/Server/SimpleHTTP.hs0000644000000000000000000002224212725110331021575 0ustar0000000000000000{-# 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 , 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 -- ** Proxying , module Happstack.Server.Proxy -- ** 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.Proxy import Happstack.Server.Routing import Happstack.Server.RqData import Happstack.Server.Response import Happstack.Server.Validation import Control.Monad import Data.Maybe (fromMaybe) import qualified Data.Version as DV import Happstack.Server.Internal.Monads (FilterFun, WebT(..), unFilterFun, runServerPartT, ununWebT) import qualified Happstack.Server.Internal.Listen as Listen (listen, listen',listenOn, listenOnIPv4) -- So that we can disambiguate 'Writer.listen' import Network (Socket) import 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 happstack-server-7.4.6.2/src/Happstack/Server/SURI.hs0000644000000000000000000000661712725110331020436 0ustar0000000000000000{-# 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 import Control.Arrow (first) import Data.Char (chr, digitToInt, isHexDigit) import Data.Maybe (fromJust, isJust) import Data.Generics (Data, Typeable) 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 path = URI.uriPath . suri -- | Retrieves the query component from the URI query :: SURI -> String query = URI.uriQuery . suri -- | Retrieves the scheme component from the URI scheme :: SURI -> String scheme = URI.uriScheme . suri -- | Modifies the scheme component of the URI using the provided function u_scheme :: (String -> String) -> SURI -> SURI u_scheme f (SURI u) = SURI (u {URI.uriScheme=f $ URI.uriScheme u}) -- | Modifies the path component of the URI using the provided function u_path :: (String -> String) -> SURI -> SURI u_path f (SURI u) = SURI $ u {URI.uriPath=f $ URI.uriPath u} -- | Sets the scheme component of the URI a_scheme :: String -> SURI -> SURI a_scheme a (SURI u) = SURI $ u {URI.uriScheme=a} -- | Sets the path component of the URI a_path :: String -> SURI -> SURI a_path a (SURI u) = SURI $ u {URI.uriPath=a} -- | percent decode a String -- -- e.g. @\"hello%2Fworld\"@ -> @\"hello/world\"@ percentDecode :: String -> String percentDecode [] = "" percentDecode ('%':x1:x2:s) | isHexDigit x1 && isHexDigit x2 = chr (digitToInt x1 * 16 + digitToInt x2) : percentDecode s percentDecode (c:s) = c : percentDecode s unEscape, unEscapeQS :: String -> String unEscapeQS = percentDecode . map (\x->if x=='+' then ' ' else x) unEscape = percentDecode -- escape = URI.escapeURIString URI.isAllowedInURI -- | Returns true if the URI is absolute isAbs :: SURI -> Bool isAbs = not . null . URI.uriScheme . suri newtype SURI = SURI {suri::URI.URI} deriving (Eq,Data,Typeable) 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 where mapFst :: (a -> b) -> [(a,x)] -> [(b,x)] mapFst = map . first instance Ord SURI where compare a b = show a `compare` show b -- | Render should be used for prettyprinting URIs. render :: (ToSURI a) => a -> String render = show . suri . toSURI -- | Parses a URI from a String. Returns Nothing on failure. parse :: String -> Maybe SURI 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 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 happstack-server-7.4.6.2/src/Happstack/Server/Types.hs0000644000000000000000000000143312725110331020747 0ustar0000000000000000module 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 happstack-server-7.4.6.2/src/Happstack/Server/Validation.hs0000644000000000000000000001404012725110331021733 0ustar0000000000000000-- | 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) happstack-server-7.4.6.2/src/Happstack/Server/FileServe/0000755000000000000000000000000012725110331021172 5ustar0000000000000000happstack-server-7.4.6.2/src/Happstack/Server/FileServe/BuildingBlocks.hs0000644000000000000000000013014512725110331024425 0ustar0000000000000000{-# LANGUAGE 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.Applicative ((<$>)) import Control.Exception.Extensible as E (IOException, bracket, catch) import Control.Monad (MonadPlus(mzero), msum) import Control.Monad.Trans (MonadIO(liftIO)) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S import Data.Data (Data, Typeable) import Data.List (sort) import Data.Maybe (fromMaybe) import Data.Map (Map) import qualified Data.Map as Map import Data.Time.Compat (toUTCTime) 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 #if MIN_VERSION_time(1,5,0) import Data.Time (UTCTime, formatTime, defaultTimeLocale) #else import System.Locale (defaultTimeLocale) import Data.Time (UTCTime, formatTime) #endif -- * 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 ext mimeMap -- | 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 argument 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 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 (toUTCTime 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 (toUTCTime 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 (toUTCTime 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, Typeable, 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 . toUTCTime <$> 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, Typeable) -- | 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 an Ubuntu 8.04 \/etc\/mime.types file. mimeTypes :: MimeMap mimeTypes = Map.fromList [("gz","application/x-gzip"),("cabal","text/x-cabal"),("%","application/x-trash"),("323","text/h323"),("3gp","video/3gpp"),("7z","application/x-7z-compressed"),("abw","application/x-abiword"),("ai","application/postscript"),("aif","audio/x-aiff"),("aifc","audio/x-aiff"),("aiff","audio/x-aiff"),("alc","chemical/x-alchemy"),("art","image/x-jg"),("asc","text/plain"),("asf","video/x-ms-asf"),("asn","chemical/x-ncbi-asn1"),("aso","chemical/x-ncbi-asn1-binary"),("asx","video/x-ms-asf"),("atom","application/atom"),("atomcat","application/atomcat+xml"),("atomsrv","application/atomserv+xml"),("au","audio/basic"),("avi","video/x-msvideo"),("b","chemical/x-molconn-Z"),("bak","application/x-trash"),("bat","application/x-msdos-program"),("bcpio","application/x-bcpio"),("bib","text/x-bibtex"),("bin","application/octet-stream"),("bmp","image/x-ms-bmp"),("boo","text/x-boo"),("book","application/x-maker"),("bsd","chemical/x-crossfire"),("c","text/x-csrc"),("c++","text/x-c++src"),("c3d","chemical/x-chem3d"),("cab","application/x-cab"),("cac","chemical/x-cache"),("cache","chemical/x-cache"),("cap","application/cap"),("cascii","chemical/x-cactvs-binary"),("cat","application/vnd.ms-pki.seccat"),("cbin","chemical/x-cactvs-binary"),("cbr","application/x-cbr"),("cbz","application/x-cbz"),("cc","text/x-c++src"),("cdf","application/x-cdf"),("cdr","image/x-coreldraw"),("cdt","image/x-coreldrawtemplate"),("cdx","chemical/x-cdx"),("cdy","application/vnd.cinderella"),("cef","chemical/x-cxf"),("cer","chemical/x-cerius"),("chm","chemical/x-chemdraw"),("chrt","application/x-kchart"),("cif","chemical/x-cif"),("class","application/java-vm"),("cls","text/x-tex"),("cmdf","chemical/x-cmdf"),("cml","chemical/x-cml"),("cod","application/vnd.rim.cod"),("com","application/x-msdos-program"),("cpa","chemical/x-compass"),("cpio","application/x-cpio"),("cpp","text/x-c++src"),("cpt","application/mac-compactpro"),("crl","application/x-pkcs7-crl"),("crt","application/x-x509-ca-cert"),("csf","chemical/x-cache-csf"),("csh","application/x-csh"),("csm","chemical/x-csml"),("csml","chemical/x-csml"),("css","text/css"),("csv","text/csv"),("ctab","chemical/x-cactvs-binary"),("ctx","chemical/x-ctx"),("cu","application/cu-seeme"),("cub","chemical/x-gaussian-cube"),("cxf","chemical/x-cxf"),("cxx","text/x-c++src"),("d","text/x-dsrc"),("dat","chemical/x-mopac-input"),("dcr","application/x-director"),("deb","application/x-debian-package"),("dif","video/dv"),("diff","text/x-diff"),("dir","application/x-director"),("djv","image/vnd.djvu"),("djvu","image/vnd.djvu"),("dl","video/dl"),("dll","application/x-msdos-program"),("dmg","application/x-apple-diskimage"),("dms","application/x-dms"),("doc","application/msword"),("dot","application/msword"),("dv","video/dv"),("dvi","application/x-dvi"),("dx","chemical/x-jcamp-dx"),("dxr","application/x-director"),("emb","chemical/x-embl-dl-nucleotide"),("embl","chemical/x-embl-dl-nucleotide"),("eml","message/rfc822"),("ent","chemical/x-ncbi-asn1-ascii"),("eps","application/postscript"),("etx","text/x-setext"),("exe","application/x-msdos-program"),("ez","application/andrew-inset"),("fb","application/x-maker"),("fbdoc","application/x-maker"),("fch","chemical/x-gaussian-checkpoint"),("fchk","chemical/x-gaussian-checkpoint"),("fig","application/x-xfig"),("flac","application/x-flac"),("fli","video/fli"),("fm","application/x-maker"),("frame","application/x-maker"),("frm","application/x-maker"),("gal","chemical/x-gaussian-log"),("gam","chemical/x-gamess-input"),("gamin","chemical/x-gamess-input"),("gau","chemical/x-gaussian-input"),("gcd","text/x-pcs-gcd"),("gcf","application/x-graphing-calculator"),("gcg","chemical/x-gcg8-sequence"),("gen","chemical/x-genbank"),("gf","application/x-tex-gf"),("gif","image/gif"),("gjc","chemical/x-gaussian-input"),("gjf","chemical/x-gaussian-input"),("gl","video/gl"),("gnumeric","application/x-gnumeric"),("gpt","chemical/x-mopac-graph"),("gsf","application/x-font"),("gsm","audio/x-gsm"),("gtar","application/x-gtar"),("h","text/x-chdr"),("h++","text/x-c++hdr"),("hdf","application/x-hdf"),("hh","text/x-c++hdr"),("hin","chemical/x-hin"),("hpp","text/x-c++hdr"),("hqx","application/mac-binhex40"),("hs","text/x-haskell"),("hta","application/hta"),("htc","text/x-component"),("htm","text/html"),("html","text/html"),("hxx","text/x-c++hdr"),("ica","application/x-ica"),("ice","x-conference/x-cooltalk"),("ico","image/x-icon"),("ics","text/calendar"),("icz","text/calendar"),("ief","image/ief"),("iges","model/iges"),("igs","model/iges"),("iii","application/x-iphone"),("inp","chemical/x-gamess-input"),("ins","application/x-internet-signup"),("iso","application/x-iso9660-image"),("isp","application/x-internet-signup"),("ist","chemical/x-isostar"),("istr","chemical/x-isostar"),("jad","text/vnd.sun.j2me.app-descriptor"),("jar","application/java-archive"),("java","text/x-java"),("jdx","chemical/x-jcamp-dx"),("jmz","application/x-jmol"),("jng","image/x-jng"),("jnlp","application/x-java-jnlp-file"),("jpe","image/jpeg"),("jpeg","image/jpeg"),("jpg","image/jpeg"),("js","application/x-javascript"),("kar","audio/midi"),("key","application/pgp-keys"),("kil","application/x-killustrator"),("kin","chemical/x-kinemage"),("kml","application/vnd.google-earth.kml+xml"),("kmz","application/vnd.google-earth.kmz"),("kpr","application/x-kpresenter"),("kpt","application/x-kpresenter"),("ksp","application/x-kspread"),("kwd","application/x-kword"),("kwt","application/x-kword"),("latex","application/x-latex"),("lha","application/x-lha"),("lhs","text/x-literate-haskell"),("lsf","video/x-la-asf"),("lsx","video/x-la-asf"),("ltx","text/x-tex"),("lyx","application/x-lyx"),("lzh","application/x-lzh"),("lzx","application/x-lzx"),("m3u","audio/mpegurl"),("m4a","audio/mpeg"),("maker","application/x-maker"),("man","application/x-troff-man"),("mcif","chemical/x-mmcif"),("mcm","chemical/x-macmolecule"),("mdb","application/msaccess"),("me","application/x-troff-me"),("mesh","model/mesh"),("mid","audio/midi"),("midi","audio/midi"),("mif","application/x-mif"),("mm","application/x-freemind"),("mmd","chemical/x-macromodel-input"),("mmf","application/vnd.smaf"),("mml","text/mathml"),("mmod","chemical/x-macromodel-input"),("mng","video/x-mng"),("moc","text/x-moc"),("mol","chemical/x-mdl-molfile"),("mol2","chemical/x-mol2"),("moo","chemical/x-mopac-out"),("mop","chemical/x-mopac-input"),("mopcrt","chemical/x-mopac-input"),("mov","video/quicktime"),("movie","video/x-sgi-movie"),("mp2","audio/mpeg"),("mp3","audio/mpeg"),("mp4","video/mp4"),("mpc","chemical/x-mopac-input"),("mpe","video/mpeg"),("mpeg","video/mpeg"),("mpega","audio/mpeg"),("mpg","video/mpeg"),("mpga","audio/mpeg"),("ms","application/x-troff-ms"),("msh","model/mesh"),("msi","application/x-msi"),("mvb","chemical/x-mopac-vib"),("mxu","video/vnd.mpegurl"),("nb","application/mathematica"),("nc","application/x-netcdf"),("nwc","application/x-nwc"),("o","application/x-object"),("oda","application/oda"),("odb","application/vnd.oasis.opendocument.database"),("odc","application/vnd.oasis.opendocument.chart"),("odf","application/vnd.oasis.opendocument.formula"),("odg","application/vnd.oasis.opendocument.graphics"),("odi","application/vnd.oasis.opendocument.image"),("odm","application/vnd.oasis.opendocument.text-master"),("odp","application/vnd.oasis.opendocument.presentation"),("ods","application/vnd.oasis.opendocument.spreadsheet"),("odt","application/vnd.oasis.opendocument.text"),("oga","audio/ogg"),("ogg","application/ogg"),("ogv","video/ogg"),("ogx","application/ogg"),("old","application/x-trash"),("otg","application/vnd.oasis.opendocument.graphics-template"),("oth","application/vnd.oasis.opendocument.text-web"),("otp","application/vnd.oasis.opendocument.presentation-template"),("ots","application/vnd.oasis.opendocument.spreadsheet-template"),("ott","application/vnd.oasis.opendocument.text-template"),("oza","application/x-oz-application"),("p","text/x-pascal"),("p7r","application/x-pkcs7-certreqresp"),("pac","application/x-ns-proxy-autoconfig"),("pas","text/x-pascal"),("pat","image/x-coreldrawpattern"),("patch","text/x-diff"),("pbm","image/x-portable-bitmap"),("pcap","application/cap"),("pcf","application/x-font"),("pcf.Z","application/x-font"),("pcx","image/pcx"),("pdb","chemical/x-pdb"),("pdf","application/pdf"),("pfa","application/x-font"),("pfb","application/x-font"),("pgm","image/x-portable-graymap"),("pgn","application/x-chess-pgn"),("pgp","application/pgp-signature"),("php","application/x-httpd-php"),("php3","application/x-httpd-php3"),("php3p","application/x-httpd-php3-preprocessed"),("php4","application/x-httpd-php4"),("phps","application/x-httpd-php-source"),("pht","application/x-httpd-php"),("phtml","application/x-httpd-php"),("pk","application/x-tex-pk"),("pl","text/x-perl"),("pls","audio/x-scpls"),("pm","text/x-perl"),("png","image/png"),("pnm","image/x-portable-anymap"),("pot","text/plain"),("ppm","image/x-portable-pixmap"),("pps","application/vnd.ms-powerpoint"),("ppt","application/vnd.ms-powerpoint"),("prf","application/pics-rules"),("prt","chemical/x-ncbi-asn1-ascii"),("ps","application/postscript"),("psd","image/x-photoshop"),("py","text/x-python"),("pyc","application/x-python-code"),("pyo","application/x-python-code"),("qt","video/quicktime"),("qtl","application/x-quicktimeplayer"),("ra","audio/x-pn-realaudio"),("ram","audio/x-pn-realaudio"),("rar","application/rar"),("ras","image/x-cmu-raster"),("rd","chemical/x-mdl-rdfile"),("rdf","application/rdf+xml"),("rgb","image/x-rgb"),("rhtml","application/x-httpd-eruby"),("rm","audio/x-pn-realaudio"),("roff","application/x-troff"),("ros","chemical/x-rosdal"),("rpm","application/x-redhat-package-manager"),("rss","application/rss+xml"),("rtf","application/rtf"),("rtx","text/richtext"),("rxn","chemical/x-mdl-rxnfile"),("sct","text/scriptlet"),("sd","chemical/x-mdl-sdfile"),("sd2","audio/x-sd2"),("sda","application/vnd.stardivision.draw"),("sdc","application/vnd.stardivision.calc"),("sdd","application/vnd.stardivision.impress"),("sdf","application/vnd.stardivision.math"),("sds","application/vnd.stardivision.chart"),("sdw","application/vnd.stardivision.writer"),("ser","application/java-serialized-object"),("sgf","application/x-go-sgf"),("sgl","application/vnd.stardivision.writer-global"),("sh","application/x-sh"),("shar","application/x-shar"),("shtml","text/html"),("sid","audio/prs.sid"),("sik","application/x-trash"),("silo","model/mesh"),("sis","application/vnd.symbian.install"),("sisx","x-epoc/x-sisx-app"),("sit","application/x-stuffit"),("sitx","application/x-stuffit"),("skd","application/x-koan"),("skm","application/x-koan"),("skp","application/x-koan"),("skt","application/x-koan"),("smi","application/smil"),("smil","application/smil"),("snd","audio/basic"),("spc","chemical/x-galactic-spc"),("spl","application/futuresplash"),("spx","audio/ogg"),("src","application/x-wais-source"),("stc","application/vnd.sun.xml.calc.template"),("std","application/vnd.sun.xml.draw.template"),("sti","application/vnd.sun.xml.impress.template"),("stl","application/vnd.ms-pki.stl"),("stw","application/vnd.sun.xml.writer.template"),("sty","text/x-tex"),("sv4cpio","application/x-sv4cpio"),("sv4crc","application/x-sv4crc"),("svg","image/svg+xml"),("svgz","image/svg+xml"),("sw","chemical/x-swissprot"),("swf","application/x-shockwave-flash"),("swfl","application/x-shockwave-flash"),("sxc","application/vnd.sun.xml.calc"),("sxd","application/vnd.sun.xml.draw"),("sxg","application/vnd.sun.xml.writer.global"),("sxi","application/vnd.sun.xml.impress"),("sxm","application/vnd.sun.xml.math"),("sxw","application/vnd.sun.xml.writer"),("t","application/x-troff"),("tar","application/x-tar"),("taz","application/x-gtar"),("tcl","application/x-tcl"),("tex","text/x-tex"),("texi","application/x-texinfo"),("texinfo","application/x-texinfo"),("text","text/plain"),("tgf","chemical/x-mdl-tgf"),("tgz","application/x-gtar"),("tif","image/tiff"),("tiff","image/tiff"),("tk","text/x-tcl"),("tm","text/texmacs"),("torrent","application/x-bittorrent"),("tr","application/x-troff"),("ts","text/texmacs"),("tsp","application/dsptype"),("tsv","text/tab-separated-values"),("txt","text/plain"),("udeb","application/x-debian-package"),("uls","text/iuls"),("ustar","application/x-ustar"),("val","chemical/x-ncbi-asn1-binary"),("vcd","application/x-cdlink"),("vcf","text/x-vcard"),("vcs","text/x-vcalendar"),("vmd","chemical/x-vmd"),("vms","chemical/x-vamas-iso14976"),("vrm","x-world/x-vrml"),("vrml","model/vrml"),("vsd","application/vnd.visio"),("wad","application/x-doom"),("wav","audio/x-wav"),("wax","audio/x-ms-wax"),("wbmp","image/vnd.wap.wbmp"),("wbxml","application/vnd.wap.wbxml"),("wk","application/x-123"),("wm","video/x-ms-wm"),("wma","audio/x-ms-wma"),("wmd","application/x-ms-wmd"),("wml","text/vnd.wap.wml"),("wmlc","application/vnd.wap.wmlc"),("wmls","text/vnd.wap.wmlscript"),("wmlsc","application/vnd.wap.wmlscriptc"),("wmv","video/x-ms-wmv"),("wmx","video/x-ms-wmx"),("wmz","application/x-ms-wmz"),("wp5","application/wordperfect5.1"),("wpd","application/wordperfect"),("wrl","model/vrml"),("wsc","text/scriptlet"),("wvx","video/x-ms-wvx"),("wz","application/x-wingz"),("xbm","image/x-xbitmap"),("xcf","application/x-xcf"),("xht","application/xhtml+xml"),("xhtml","application/xhtml+xml"),("xlb","application/vnd.ms-excel"),("xls","application/vnd.ms-excel"),("xlt","application/vnd.ms-excel"),("xml","application/xml"),("xpi","application/x-xpinstall"),("xpm","image/x-xpixmap"),("xsl","application/xml"),("xtel","chemical/x-xtel"),("xul","application/vnd.mozilla.xul+xml"),("xwd","image/x-xwindowdump"),("xyz","chemical/x-xyz"),("zip","application/zip"),("zmt","chemical/x-mopac-input"),("~","application/x-trash")] happstack-server-7.4.6.2/src/Happstack/Server/Internal/0000755000000000000000000000000012725110331021062 5ustar0000000000000000happstack-server-7.4.6.2/src/Happstack/Server/Internal/Clock.hs0000644000000000000000000000355212725110331022456 0ustar0000000000000000{-# OPTIONS -fno-cse #-} module Happstack.Server.Internal.Clock ( getApproximateTime , getApproximatePOSIXTime , getApproximateUTCTime , formatHttpDate ) where import Control.Applicative ((<$>)) import Control.Concurrent import Control.Monad import Data.IORef import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime) import System.IO.Unsafe #if MIN_VERSION_time(1,5,0) import Data.Time.Format (formatTime, defaultTimeLocale) #else import Data.Time.Format (formatTime) import System.Locale (defaultTimeLocale) #endif import qualified Data.ByteString.Char8 as B 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 happstack-server-7.4.6.2/src/Happstack/Server/Internal/Compression.hs0000644000000000000000000002576312725110331023734 0ustar0000000000000000{-# LANGUAGE 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 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) => 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) => [(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) => 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) => [(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) => [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 happstack-server-7.4.6.2/src/Happstack/Server/Internal/Cookie.hs0000644000000000000000000001662512725110331022641 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} -- http://tools.ietf.org/html/rfc2109 module Happstack.Server.Internal.Cookie ( Cookie(..) , CookieLife(..) , calcLife , mkCookie , mkCookieHeader , getCookies , getCookie , getCookies' , getCookie' , parseCookies , cookiesParser ) where import Control.Monad import qualified Data.ByteString.Char8 as C import Data.Char (chr, toLower) import Data.Data (Data, Typeable) import Data.List ((\\), intersperse) import Data.Time.Clock (UTCTime, addUTCTime, diffUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Happstack.Server.Internal.Clock (getApproximateUTCTime) import Text.ParserCombinators.Parsec hiding (token) #if MIN_VERSION_time(1,5,0) import Data.Time.Format (formatTime, defaultTimeLocale) #else import Data.Time.Format (formatTime) import System.Locale (defaultTimeLocale) #endif -- | 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 } deriving(Show,Eq,Read,Typeable,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, Typeable) -- 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 and httpOnly == False -- -- see also: 'addCookie' mkCookie :: String -- ^ cookie name -> String -- ^ cookie value -> Cookie mkCookie key val = Cookie "1" "/" "" key val False 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 defaultTimeLocale "%a, %d-%b-%Y %X GMT" . snd) mLife) ,("Path=", cookiePath cookie) ,("Version=", s cookieVersion)] s f | f cookie == "" = "" s f = '\"' : concatMap e (f cookie) ++ "\"" e c | fctl c || c == '"' = ['\\',c] | otherwise = [c] in concat $ intersperse ";" ((cookieName cookie++"="++s cookieValue):[ (k++v) | (k,v) <- l, "" /= v ] ++ (if secure cookie then ["Secure"] else []) ++ (if httpOnly cookie then ["HttpOnly"] else [])) fctl :: Char -> Bool fctl ch = ch == chr 127 || ch <= chr 31 -- | 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 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 :: 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 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 [] -> fail "No cookie found" f -> return $ head f low :: String -> String low = map toLower happstack-server-7.4.6.2/src/Happstack/Server/Internal/Handler.hs0000644000000000000000000004334412725110331023003 0ustar0000000000000000{-# 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.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' <- parseHeaders "host" (L.unpack headerStr) let headers = mkHeaders headers' let contentLen = fromMaybe 0 $ fmap fst (P.readInt =<< getHeaderUnsafe contentlengthC headers) (body, nextRequest) <- case () of () | contentLen < 0 -> fail "negative content-length" | 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) -> return $ 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.catch` \(e::E.SomeException) -> return (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 -- 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' <- 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 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") happstack-server-7.4.6.2/src/Happstack/Server/Internal/LazyLiner.hs0000644000000000000000000000273712725110331023340 0ustar0000000000000000{-# 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 happstack-server-7.4.6.2/src/Happstack/Server/Internal/Listen.hs0000644000000000000000000001110012725110331022645 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} module Happstack.Server.Internal.Listen(listen, listen',listenOn,listenOnIPv4) where 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 Network.BSD (getProtocolNumber) import Network (Socket) import Network.Socket as Socket (SocketOption(KeepAlive), close, setSocketOption, socket, Family(..), SockAddr, SocketOption(..), SockAddr(..), iNADDR_ANY, maxListenQueue, SocketType(..), bindSocket) import qualified Network.Socket as Socket (listen, inet_addr) import System.IO.Error (isFullError) {- #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" {- 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 listenOn portm = do proto <- getProtocolNumber "tcp" E.bracketOnError (socket AF_INET Stream proto) (close) (\sock -> do setSocketOption sock ReuseAddr 1 bindSocket sock (SockAddrInet (fromIntegral portm) iNADDR_ANY) Socket.listen sock (max 1024 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 listenOnIPv4 ip portm = do proto <- getProtocolNumber "tcp" hostAddr <- Socket.inet_addr ip E.bracketOnError (socket AF_INET Stream proto) (close) (\sock -> do setSocketOption sock ReuseAddr 1 bindSocket sock (SockAddrInet (fromIntegral portm) hostAddr) Socket.listen sock (max 1024 maxListenQueue) return sock ) -- | Bind and listen port listen :: Conf -> (Request -> IO Response) -> IO () listen conf hand = do let port' = port conf lsocket <- listenOn port' setSocketOption lsocket KeepAlive 1 listen' lsocket conf hand -- | Use a previously bind port and listen listen' :: 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 close sock loop = forever $ do w <- acceptLite s fork $ work w pe e = log' ERROR ("ERROR in http accept thread: " ++ show e) infi :: IO () infi = loop `catchSome` pe >> infi infi `finally` (close s >> forceTimeoutAll tm) {-- #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 ] happstack-server-7.4.6.2/src/Happstack/Server/Internal/LogFormat.hs0000644000000000000000000000412412725110331023311 0ustar0000000000000000module Happstack.Server.Internal.LogFormat ( formatTimeCombined , formatRequestCombined ) where #if MIN_VERSION_time(1,5,0) import Data.Time.Format (FormatTime(..), formatTime, defaultTimeLocale) #else import Data.Time.Format (FormatTime(..), formatTime) import System.Locale (defaultTimeLocale) #endif -- | 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 happstack-server-7.4.6.2/src/Happstack/Server/Internal/LowLevel.hs0000644000000000000000000000155012725110331023150 0ustar0000000000000000module 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. happstack-server-7.4.6.2/src/Happstack/Server/Internal/MessageWrap.hs0000644000000000000000000001550012725110331023635 0ustar0000000000000000{-# 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' happstack-server-7.4.6.2/src/Happstack/Server/Internal/Monads.hs0000644000000000000000000010235012725110331022640 0ustar0000000000000000{-# 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.Monad ( MonadPlus(mzero, mplus), ap, liftM, msum ) import Control.Monad.Base ( MonadBase, liftBase ) import Control.Monad.Catch ( MonadCatch(..), MonadThrow(..) ) import Control.Monad.Error ( ErrorT(ErrorT), runErrorT , Error, MonadError, throwError , catchError, mapErrorT ) 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, mapExceptT ) 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 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 (canHaveBody) 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 } deriving (Monad, MonadPlus, Functor) 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 #-} #if MIN_VERSION_monad_control(1,0,0) 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 #else instance MonadTransControl ServerPartT where newtype StT ServerPartT a = StSP {unStSP :: StT WebT (StT (ReaderT Request) a)} liftWith f = ServerPartT $ liftWith $ \runReader -> liftWith $ \runWeb -> f $ liftM StSP . runWeb . runReader . unServerPartT restoreT = ServerPartT . restoreT . restoreT . liftM unStSP instance MonadBaseControl b m => MonadBaseControl b (ServerPartT m) where newtype StM (ServerPartT m) a = StMSP {unStMSP :: ComposeSt ServerPartT m a} liftBaseWith = defaultLiftBaseWith StMSP restoreM = defaultRestoreM unStMSP #endif -- | 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) => Monoid (ServerPartT m a) where mempty = mzero mappend = mplus 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 => 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 -- | 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 #-} #if MIN_VERSION_monad_control(1,0,0) 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 #else instance MonadTransControl (FilterT a) where newtype StT (FilterT a) b = StFilter {unStFilter :: StT (Lazy.WriterT (FilterFun a)) b} liftWith f = FilterT $ liftWith $ \run -> f $ liftM StFilter . run . unFilterT restoreT = FilterT . restoreT . liftM unStFilter instance MonadBaseControl b m => MonadBaseControl b (FilterT a m) where newtype StM (FilterT a m) c = StMFilter {unStMFilter :: ComposeSt (FilterT a) m c} liftBaseWith = defaultLiftBaseWith StMFilter restoreM = defaultRestoreM unStMFilter #endif -- | 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 :: ErrorT 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 #-} #if MIN_VERSION_monad_control(1,0,0) instance MonadTransControl WebT where type StT WebT a = StT MaybeT (StT (FilterT Response) (StT (ErrorT Response) a)) liftWith f = WebT $ liftWith $ \runError -> liftWith $ \runFilter -> liftWith $ \runMaybe -> f $ runMaybe . runFilter . runError . 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 #else instance MonadTransControl WebT where newtype StT WebT a = StWeb {unStWeb :: StT MaybeT (StT (FilterT Response) (StT (ErrorT Response) a))} liftWith f = WebT $ liftWith $ \runError -> liftWith $ \runFilter -> liftWith $ \runMaybe -> f $ liftM StWeb . runMaybe . runFilter . runError . unWebT restoreT = WebT . restoreT . restoreT . restoreT . liftM unStWeb instance MonadBaseControl b m => MonadBaseControl b (WebT m) where newtype StM (WebT m) a = StMWeb {unStMWeb :: ComposeSt WebT m a} liftBaseWith = defaultLiftBaseWith StMWeb restoreM = defaultRestoreM unStMWeb #endif -- | '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 #-} fail s = lift (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 $ ErrorT $ FilterT $ (lower x) `mplus` (lower y) where lower = (unFilterT . runErrorT . unWebT) instance (Monad m) => FilterMonad Response (WebT m) where setFilter f = WebT $ lift $ setFilter $ f composeFilter f = WebT . lift . composeFilter $ f getFilter m = WebT $ ErrorT $ liftM lft $ getFilter (runErrorT $ unWebT m) where lft (Left r, _) = Left r lft (Right a, f) = Right (a, f) instance (Monad m, MonadPlus m) => Monoid (WebT m a) where mempty = mzero mappend = mplus -- | For when you really need to unpack a 'WebT' entirely (and not -- just unwrap the first layer with 'unWebT'). ununWebT :: WebT m a -> UnWebT m a ununWebT = runMaybeT . Lazy.runWriterT . unFilterT . runErrorT . unWebT -- | For wrapping a 'WebT' back up. @'mkWebT' . 'ununWebT' = 'id'@ mkWebT :: UnWebT m a -> WebT m a mkWebT = WebT . ErrorT . 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 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 -- 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 happstack-server-7.4.6.2/src/Happstack/Server/Internal/Multipart.hs0000644000000000000000000003060412725110331023402 0ustar0000000000000000module 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 = do (fn, h) <- openBinaryTempFile tmpDir filename (trunc, len) <- hPutLimit diskQuota h b hClose h return (trunc, len, fn) 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 #-} happstack-server-7.4.6.2/src/Happstack/Server/Internal/RFC822Headers.hs0000644000000000000000000001757112725110331023573 0ustar0000000000000000-- #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 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 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 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 :: 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 void $ 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 void $ 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; 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 happstack-server-7.4.6.2/src/Happstack/Server/Internal/Socket.hs0000644000000000000000000000706412725110331022655 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef TEMPLATE_HASKELL {-# LANGUAGE TemplateHaskell #-} #endif module Happstack.Server.Internal.Socket ( acceptLite , sockAddrToPeer ) where import Data.List (intersperse) import Data.Word (Word32) #ifdef TEMPLATE_HASKELL import Happstack.Server.Internal.SocketTH(supportsIPv6) import Language.Haskell.TH.Syntax #endif import qualified Network.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 = #ifdef TEMPLATE_HASKELL $(if supportsIPv6 then return $ CaseE (VarE (mkName "addr")) [ Match (ConP (mkName "S.SockAddrInet") [VarP (mkName "p"),VarP (mkName "ha")]) (NormalB (TupE [(AppE (VarE (mkName "showHostAddress")) (VarE (mkName "ha"))) , VarE (mkName "p") ])) [] , Match (ConP (mkName "S.SockAddrInet6") [VarP (mkName "p"),WildP,VarP (mkName "ha"),WildP]) (NormalB (TupE [ (AppE (VarE (mkName "showHostAddress6")) (VarE (mkName "ha"))) , VarE (mkName "p") ])) [] , Match WildP (NormalB (AppE (VarE (mkName "error")) (LitE (StringL "Unsupported socket")))) []] -- the above mess is the equivalent of this: {-[| case addr of (S.SockAddrInet p ha) -> (showHostAddress ha, p) (S.SockAddrInet6 p _ ha _ ) -> (showHostAddress6 ha, p) _ -> error "Unsupported socket" |]-} else [| case addr of (S.SockAddrInet p ha) -> (showHostAddress ha, p) _ -> error "Unsupported socket" |]) #else case addr of (S.SockAddrInet p ha) -> (showHostAddress ha, p) _ -> error "Unsupported socket" #endif happstack-server-7.4.6.2/src/Happstack/Server/Internal/SocketTH.hs0000644000000000000000000000222212725110331023100 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef TEMPLATE_HASKELL {-# LANGUAGE TemplateHaskell #-} #endif module Happstack.Server.Internal.SocketTH(supportsIPv6) where #ifdef TEMPLATE_HASKELL import Language.Haskell.TH #endif import Network.Socket(SockAddr(..)) -- find out at compile time if the SockAddr6 / HostAddress6 constructors are available supportsIPv6 :: Bool #ifdef TEMPLATE_HASKELL supportsIPv6 = $(let c = ["Network.Socket.SockAddrInet6", "Network.Socket.Internal.SockAddrInet6"] ; d = ''SockAddr isInet6 :: Con -> Bool isInet6 (NormalC n _) = show n `elem` c isInet6 _ = False in do info <- reify d case info of #if MIN_VERSION_template_haskell(2,11,0) TyConI (DataD _ _ _ _ cs _) -> #else TyConI (DataD _ _ _ cs _) -> #endif if any isInet6 cs then [| True |] else [| False |] _ -> error "supportsIPv6: SockAddr is no longer a TyConI ?!?! Giving up." ) #else supportsIPv6 = False #endif happstack-server-7.4.6.2/src/Happstack/Server/Internal/TimeoutIO.hs0000644000000000000000000000146512725110331023302 0ustar0000000000000000module Happstack.Server.Internal.TimeoutIO ( TimeoutIO(..) ) where import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L import Happstack.Server.Internal.TimeoutManager (Handle) import Network.Socket.SendFile (ByteCount, Offset) -- |TimeoutIO is a record which abstracts out all the network IO -- functions needed by the request handling loop. This allows use to -- use the same event loop for handle both http:// and https://. data TimeoutIO = TimeoutIO { toHandle :: Handle , toPutLazy :: L.ByteString -> IO () , toPut :: B.ByteString -> IO () , toGetContents :: IO L.ByteString , toSendFile :: FilePath -> Offset -> ByteCount -> IO () , toShutdown :: IO () , toSecure :: Bool } happstack-server-7.4.6.2/src/Happstack/Server/Internal/TimeoutManager.hs0000644000000000000000000000466112725110331024346 0ustar0000000000000000module 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 happstack-server-7.4.6.2/src/Happstack/Server/Internal/TimeoutSocket.hs0000644000000000000000000000670312725110331024223 0ustar0000000000000000{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} {- | -- borrowed from snap-server. Check there periodically for updates. -} module Happstack.Server.Internal.TimeoutSocket where 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 (sClose) import qualified Network.Socket.ByteString as N import qualified Happstack.Server.Internal.TimeoutManager as TM import Happstack.Server.Internal.TimeoutIO (TimeoutIO(..)) import Network.Socket (Socket, ShutdownCmd(..), shutdown) import Network.Socket.SendFile (Iter(..), ByteCount, Offset, sendFileIterWith') import Network.Socket.ByteString (sendAll) import 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 #-} 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 = sClose socket , toPutLazy = sPutLazyTickle handle socket , toPut = sPutTickle handle socket , toGetContents = sGetContents handle socket , toSendFile = sendFileTickle handle socket , toSecure = False } happstack-server-7.4.6.2/src/Happstack/Server/Internal/Types.hs0000644000000000000000000005240512725110331022530 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, RankNTypes #-} 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 ) where import Control.Monad.Error (Error(strMsg)) 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 Data.Typeable(Typeable) import qualified Data.ByteString.Char8 as P import Data.ByteString.Char8 (ByteString,pack) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.UTF8 as LU (fromString) import Data.Int (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 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,Typeable,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,Typeable) -- | 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, Typeable) -- | hostname & port type Host = (String, Int) -- ^ (hostname, port) -- | an HTTP Response data Response = Response { rsCode :: Int , rsHeaders :: Headers , rsFlags :: RsFlags , rsBody :: L.ByteString , rsValidator :: Maybe (Response -> IO Response) } | SendFile { rsCode :: Int , rsHeaders :: Headers , rsFlags :: RsFlags , rsValidator :: Maybe (Response -> IO Response) , sfFilePath :: FilePath -- ^ file handle to send from , sfOffset :: Integer -- ^ offset to start at , sfCount :: Integer -- ^ number of bytes to send } deriving (Typeable) 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 ") -- what should the status code be ? instance Error Response where strMsg str = setHeader "Content-Type" "text/plain; charset=UTF-8" $ result 500 str -- | an HTTP request data Request = Request { rqSecure :: Bool -- ^ request uses https:\/\/ , rqMethod :: Method -- ^ request method , rqPaths :: [String] -- ^ the uri, split on /, and then decoded , rqUri :: String -- ^ the raw rqUri , rqQuery :: String -- ^ the QUERY_STRING , rqInputsQuery :: [(String,Input)] -- ^ the QUERY_STRING decoded as key/value pairs , rqInputsBody :: MVar [(String,Input)] -- ^ the request body decoded as key/value pairs (when appropriate) , rqCookies :: [(String,Cookie)] -- ^ cookies , rqVersion :: HttpVersion -- ^ HTTP version , rqHeaders :: Headers -- ^ the HTTP request headers , rqBody :: MVar RqBody -- ^ the raw, undecoded request body , rqPeer :: Host -- ^ (hostname, port) of the client making the request } deriving (Typeable) 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,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 (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 :: (Monad m, Read t) => String -> m t readM s = case reads s of [(v,"")] -> return v _ -> fail "readM: parse error" -- |convert a 'ReadS a' result to 'Maybe a' fromReadS :: [(a, String)] -> Maybe a fromReadS [(n,[])] = Just n fromReadS _ = Nothing -- | This class is used by 'path' to parse a path component into a -- value. -- -- The instances for number types ('Int', 'Float', etc) use 'readM' to -- parse the path component. -- -- 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 happstack-server-7.4.6.2/src/Happstack/Server/SURI/0000755000000000000000000000000012725110331020070 5ustar0000000000000000happstack-server-7.4.6.2/src/Happstack/Server/SURI/ParseURI.hs0000644000000000000000000000733712725110331022070 0ustar0000000000000000module 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 parseURIRef :: ByteString -> URI parseURIRef fs = case break (\c -> ':' == c || '/' == c || '?' == c || '#' == c) fs of (initial,rest) -> let ui = unpack initial in case uncons rest of Nothing -> if null initial then nullURI -- empty uri else -- uri not containing either ':' or '/' nullURI { uriPath = ui } Just (c, rrest) -> case c of ':' -> pabsuri rrest $ URI (unpack initial) '/' -> puriref fs $ URI "" Nothing '?' -> pquery rrest $ URI "" Nothing ui '#' -> pfragment rrest $ URI "" Nothing ui "" _ -> error "parseURIRef: Can't happen" pabsuri :: ByteString -> (Maybe URIAuth -> String -> String -> String -> b) -> b pabsuri fs cont = if length fs >= 2 && unsafeHead fs == '/' && unsafeIndex fs 1 == '/' then pauthority (drop 2 fs) cont else puriref fs $ cont Nothing pauthority :: ByteString -> (Maybe URIAuth -> String -> String -> String -> b) -> b pauthority fs cont = let (auth,rest) = breakChar '/' fs in puriref rest $! cont (Just $! pauthinner auth) pauthinner :: ByteString -> URIAuth pauthinner fs = case breakChar '@' fs of (a,b) -> pauthport b $ URIAuth (unpack a) pauthport :: ByteString -> (String -> String -> t) -> t pauthport fs cont = let spl idx = splitAt (idx+1) fs in case unsafeHead fs of _ | null fs -> cont "" "" '[' -> case fmap spl (elemIndexEnd ']' fs) of Just (a,b) | null b -> cont (unpack a) "" | unsafeHead b == ':' -> cont (unpack a) (unpack $ unsafeTail b) x -> error ("Parsing uri failed (pauthport):"++show x) _ -> case breakCharEnd ':' fs of (a,b) -> cont (unpack a) (unpack b) puriref :: ByteString -> (String -> String -> String -> b) -> b puriref fs cont = let (u,r) = break (\c -> '#' == c || '?' == c) fs in case unsafeHead r of _ | null r -> cont (unpack u) "" "" '?' -> pquery (unsafeTail r) $ cont (unpack u) '#' -> pfragment (unsafeTail r) $ cont (unpack u) "" _ -> error "unexpected match" pquery :: ByteString -> (String -> String -> t) -> t pquery fs cont = case breakChar '#' fs of (a,b) -> cont ('?':unpack a) (unpack b) pfragment :: ByteString -> (String -> b) -> b pfragment fs cont = cont $ unpack fs unsafeTail :: ByteString -> ByteString unsafeTail = BB.unsafeTail unsafeHead :: ByteString -> Char unsafeHead = BB.w2c . BB.unsafeHead 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 happstack-server-7.4.6.2/tests/0000755000000000000000000000000012725110331014475 5ustar0000000000000000happstack-server-7.4.6.2/tests/Test.hs0000644000000000000000000000120612725110331015747 0ustar0000000000000000module Main where import Happstack.Server.Tests (allTests) import Test.HUnit (errors, failures, putTextToShowS,runTestText, runTestTT) import System.Exit (exitFailure) import System.IO (hIsTerminalDevice, stdout) -- |A simple driver for running the local test suite. main :: IO () main = do c <- do istty <- hIsTerminalDevice stdout if istty then runTestTT allTests else do (c,st) <- runTestText putTextToShowS allTests putStrLn (st "") return c case (failures c) + (errors c) of 0 -> return () _ -> exitFailure happstack-server-7.4.6.2/tests/Happstack/0000755000000000000000000000000012725110331016413 5ustar0000000000000000happstack-server-7.4.6.2/tests/Happstack/Server/0000755000000000000000000000000012725110331017661 5ustar0000000000000000happstack-server-7.4.6.2/tests/Happstack/Server/Tests.hs0000644000000000000000000002657512725110331021336 0ustar0000000000000000-- |HUnit tests and QuickQuick properties for Happstack.Server.* module Happstack.Server.Tests (allTests) where import qualified Codec.Compression.GZip as GZ import qualified Codec.Compression.Zlib as Z import Control.Arrow ((&&&)) import Control.Applicative ((<$>)) import Control.Concurrent.MVar import Control.Monad import Data.ByteString.Lazy.Char8 (pack, unpack) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map import Happstack.Server ( Request(..), Method(..), Response(..), ServerPart, Headers, RqBody(Body), HttpVersion(..) , ToMessage(..), HeaderPair(..), ok, dir, simpleHTTP'', composeFilter, noContentLength, matchMethod) import Happstack.Server.FileServe.BuildingBlocks (sendFileResponse) import Happstack.Server.Cookie import Happstack.Server.Internal.Compression import Happstack.Server.Internal.Cookie import Happstack.Server.Internal.Multipart import Happstack.Server.Internal.MessageWrap import Happstack.Server.SURI(ToSURI(..), path, query) import Test.HUnit as HU (Test(..), (~:), (@?=), (@=?), assertEqual) import Text.ParserCombinators.Parsec -- |All of the tests for happstack-util should be listed here. allTests :: Test allTests = "happstack-server tests" ~: [ cookieParserTest , acceptEncodingParserTest , multipart , compressFilterResponseTest , matchMethodTest , cookieHeaderOrderTest ] cookieParserTest :: Test cookieParserTest = "cookieParserTest" ~: [parseCookies "$Version=1;Cookie1=value1;$Path=\"/testpath\";$Domain=example.com;cookie2=value2" @?= (Right [ Cookie "1" "/testpath" "example.com" "cookie1" "value1" False False , Cookie "1" "" "" "cookie2" "value2" False False ]) ,parseCookies " \t $Version = \"1\" ; cookie1 = \"randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|\" , $Path=/ " @?= (Right [ Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/|" False False ]) ,parseCookies " cookie1 = value1 " @?= (Right [ Cookie "" "" "" "cookie1" "value1" False False ]) ,parseCookies " $Version=\"1\";buggygooglecookie = valuewith=whereitshouldnotbe " @?= (Right [ Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" False False ]) , parseCookies "foo=\"\\\"bar\\\"\"" @?= (Right [ Cookie "" "" "" "foo" "\"bar\"" False False ]) ] acceptEncodingParserTest :: Test acceptEncodingParserTest = "acceptEncodingParserTest" ~: map (\(str, result) -> either (Left . show) Right (parse encodings "" str) @?= (Right result)) acceptEncodings where acceptEncodings = [ (" gzip;q=1,*, compress ; q = 0.5 ", [("gzip", Just 1),("*", Nothing),("compress", Just 0.5)]) , (" compress , gzip", [ ("compress", Nothing), ("gzip", Nothing)]) , (" ", []) , (" *", [("*", Nothing)]) , (" compress;q=0.5, gzip;q=1.0", [("compress", Just 0.5), ("gzip", Just 1.0)]) , (" gzip;q=1.0, identity; q=0.5, *;q=0", [("gzip", Just 1.0), ("identity",Just 0.5), ("*", Just 0)]) , (" x-gzip",[("x-gzip", Nothing)]) ] multipart :: Test multipart = "split multipart" ~: [ ([BodyPart (pack "content-type: text/plain\r\n") (pack "1")], Nothing) @=? parseMultipartBody (pack "boundary") (pack "--boundary\r\ncontent-type: text/plain\r\n\r\n1\r\n--boundary--\r\nend") , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1")], Nothing) @=? parseMultipartBody (pack "boundary.with.dot") (pack "--boundary.with.dot\r\ncontent-type: text/plain\r\n\r\n1\r\n--boundary.with.dot--\r\nend") , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1")], Nothing) @=? parseMultipartBody (pack "boundary") (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\r\n--boundary--\r\nend") , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1\n")], Nothing) @=? parseMultipartBody (pack "boundary") (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\n\r\n--boundary--\r\nend") , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1\r\n")], Nothing) @=? parseMultipartBody (pack "boundary") (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\r\n\r\n--boundary--\r\nend") , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1\n\r")], Nothing) @=? parseMultipartBody (pack "boundary") (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\n\r\r\n--boundary--\r\nend") , ([BodyPart (pack "content-type: text/plain\r\n") (pack "\r\n1\n\r")], Nothing) @=? parseMultipartBody (pack "boundary") (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n\r\n1\n\r\r\n--boundary--\r\nend") ] compressFilterResponseTest :: Test compressFilterResponseTest = "compressFilterResponseTest" ~: [ uncompressedResponse , uncompressedSendFile , compressedResponseGZ , compressedResponseZ , compressedSendFile , compressedSendFileNoIdentity ] mkRequest :: Method -> String -> [(String, Cookie)] -> Headers -> L.ByteString -> IO Request mkRequest method uri cookies headers body = do let u = toSURI uri ib <- newEmptyMVar b <- newMVar (Body body) return $ Request { rqMethod = method , rqPaths = (pathEls (path u)) , rqUri = (path u) , rqQuery = (query u) , rqInputsQuery = (queryInput u) , rqInputsBody = ib , rqCookies = cookies , rqVersion = HttpVersion 1 1 , rqHeaders = headers , rqBody = b , rqPeer = ("",0) , rqSecure = False } compressPart :: ServerPart Response compressPart = do void compressedResponseFilter composeFilter noContentLength msum [ dir "response" $ ok (toResponse "compress Response") , dir "sendfile" $ ok (sendFileResponse "text/plain" "/dev/null" Nothing 0 100) ] cookieHeaderOrderTestHandler :: ServerPart Response cookieHeaderOrderTestHandler = do expireCookie "thecookie" addCookie Session $ mkCookie "thecookie" "value" ok $ toResponse $ "works" cookieHeaderOrderTest :: Test cookieHeaderOrderTest = "cookie header order test" ~: do req <- mkRequest GET "/" [] Map.empty L.empty res <- simpleHTTP'' cookieHeaderOrderTestHandler req let Just pair = (Map.lookup (B.pack "set-cookie") (rsHeaders res)) assertEqual "Add cookie wins" False $ B.isInfixOf (B.pack "Max-Age=0") (last $ hValue pair) uncompressedResponse :: Test uncompressedResponse = "uncompressedResponse" ~: do req <- mkRequest GET "/response" [] Map.empty L.empty res <- simpleHTTP'' compressPart req assertEqual "respone code" (rsCode res) 200 assertEqual "body" (unpack (rsBody res)) "compress Response" assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing uncompressedSendFile :: Test uncompressedSendFile = "uncompressedSendFile" ~: do req <- mkRequest GET "/sendfile" [] Map.empty L.empty res <- simpleHTTP'' compressPart req assertEqual "respone code" (rsCode res) 200 assertEqual "filepath" (sfFilePath res) "/dev/null" assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing compressedResponseGZ :: Test compressedResponseGZ = "compressedResponseGZ" ~: do req <- mkRequest GET "/response" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1"])) L.empty res <- simpleHTTP'' compressPart req assertEqual "respone code" (rsCode res) 200 assertEqual "body" (unpack (GZ.decompress (rsBody res))) ("compress Response") assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) (Just (B.pack "Content-Encoding", [B.pack "gzip"])) compressedResponseZ :: Test compressedResponseZ = "compressedResponseZ" ~: do req <- mkRequest GET "/response" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " deflate;q=1"])) L.empty res <- simpleHTTP'' compressPart req assertEqual "respone code" (rsCode res) 200 assertEqual "body" (unpack (Z.decompress (rsBody res))) ("compress Response") assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) (Just (B.pack "Content-Encoding", [B.pack "deflate"])) compressedSendFile :: Test compressedSendFile = "compressedSendfile" ~: do req <- mkRequest GET "/sendfile" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1"])) L.empty res <- simpleHTTP'' compressPart req assertEqual "respone code" (rsCode res) 200 assertEqual "filepath" (sfFilePath res) "/dev/null" assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing compressedSendFileNoIdentity :: Test compressedSendFileNoIdentity = "compressedSendFileNoIdentity" ~: do req <- mkRequest GET "/sendfile" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1, identity: q=0.0"])) L.empty res <- simpleHTTP'' compressPart req assertEqual "respone code" (rsCode res) 406 assertEqual "body" (unpack (rsBody res)) "" assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing matchMethodTest :: Test matchMethodTest = "matchMethodTest" ~: do forM_ gethead $ \m -> matchMethod GET m @?= True forM_ others $ \m -> matchMethod GET m @?= False forM_ gethead $ \m -> matchMethod [GET] m @?= True forM_ others $ \m -> matchMethod [GET] m @?= False forM_ gethead $ \m -> matchMethod [GET, HEAD] m @?= True forM_ others $ \m -> matchMethod [GET, HEAD] m @?= False matchMethod POST GET @?= False matchMethod POST HEAD @?= False matchMethod POST TRACE @?= False matchMethod POST POST @?= True matchMethod [POST, PUT] GET @?= False matchMethod [POST, PUT] HEAD @?= False matchMethod [POST, PUT] TRACE @?= False matchMethod [POST, PUT] POST @?= True matchMethod [POST, PUT] PUT @?= True forM_ (others) $ \m -> matchMethod (`notElem` gethead) m @?= True forM_ (gethead ++ others) $ \m -> matchMethod () m @?= True where gethead = [GET, HEAD] others = [POST, PUT, DELETE, TRACE, OPTIONS, CONNECT]