happstack-server 0.5.0.4 → 6.0.0

raw patch · 52 files changed

+5459/−3942 lines, 52 filesdep +blaze-htmldep +network-bytestringdep +textdep −HaXmldep ~happstack-datadep ~happstack-utildep ~networkPVP ok

version bump matches the API change (PVP)

Dependencies added: blaze-html, network-bytestring, text

Dependencies removed: HaXml

Dependency ranges changed: happstack-data, happstack-util, network, sendfile

API changes (from Hackage documentation)

Files

• happstack-server.cabal +56/−26
• src/Happstack/Server.hs +89/−13
• src/Happstack/Server/Auth.hs +45/−0
• src/Happstack/Server/Client.hs +26/−0
• src/Happstack/Server/Compression.hs +7/−0
• src/Happstack/Server/Cookie.hs +40/−129
• src/Happstack/Server/Error.hs +57/−0
• src/Happstack/Server/FileServe.hs +19/−0
• src/Happstack/Server/FileServe/BuildingBlocks.hs +671/−0
• src/Happstack/Server/HTTP/Client.hs +0/−53
• src/Happstack/Server/HTTP/Clock.hs +0/−30
• src/Happstack/Server/HTTP/FileServe.hs +0/−354
• src/Happstack/Server/HTTP/Handler.hs +0/−365
• src/Happstack/Server/HTTP/LazyLiner.hs +0/−41
• src/Happstack/Server/HTTP/Listen.hs +0/−94
• src/Happstack/Server/HTTP/LowLevel.hs +0/−28
• src/Happstack/Server/HTTP/Multipart.hs +0/−215
• src/Happstack/Server/HTTP/RFC822Headers.hs +0/−266
• src/Happstack/Server/HTTP/Socket.hs +0/−52
• src/Happstack/Server/HTTP/SocketTH.hs +0/−15
• src/Happstack/Server/HTTP/Types.hs +0/−260
• src/Happstack/Server/Internal/Clock.hs +59/−0
• src/Happstack/Server/Internal/Compression.hs +204/−0
• src/Happstack/Server/Internal/Cookie.hs +187/−0
• src/Happstack/Server/Internal/Handler.hs +388/−0
• src/Happstack/Server/Internal/LazyLiner.hs +41/−0
• src/Happstack/Server/Internal/Listen.hs +103/−0
• src/Happstack/Server/Internal/LowLevel.hs +28/−0
• src/Happstack/Server/Internal/MessageWrap.hs +127/−0
• src/Happstack/Server/Internal/Monads.hs +503/−0
• src/Happstack/Server/Internal/Multipart.hs +257/−0
• src/Happstack/Server/Internal/RFC822Headers.hs +266/−0
• src/Happstack/Server/Internal/Socket.hs +51/−0
• src/Happstack/Server/Internal/SocketTH.hs +15/−0
• src/Happstack/Server/Internal/TimeoutManager.hs +59/−0
• src/Happstack/Server/Internal/TimeoutSocket.hs +66/−0
• src/Happstack/Server/Internal/Types.hs +393/−0
• src/Happstack/Server/MessageWrap.hs +0/−97
• src/Happstack/Server/MinHaXML.hs +0/−214
• src/Happstack/Server/Monads.hs +86/−0
• src/Happstack/Server/Parts.hs +0/−171
• src/Happstack/Server/Proxy.hs +92/−0
• src/Happstack/Server/Response.hs +289/−0
• src/Happstack/Server/Routing.hs +206/−0
• src/Happstack/Server/RqData.hs +568/−0
• src/Happstack/Server/SURI.hs +1/−1
• src/Happstack/Server/SimpleHTTP.hs +160/−1485
• src/Happstack/Server/StdConfig.hs +0/−22
• src/Happstack/Server/Types.hs +18/−0
• src/Happstack/Server/Validation.hs +134/−0
• src/Happstack/Server/XSLT.hs +36/−6
• tests/Happstack/Server/Tests.hs +112/−5

@@ -1,7 +1,7 @@ Name:                happstack-server-Version:             0.5.0.4+Version:             6.0.0 Synopsis:            Web related tools and services.-Description:         Web framework+Description:         Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course <http://happstack.com/docs/crashcourse/index.html> License:             BSD3 License-file:        COPYING Author:              Happstack team, HAppS LLC@@ -14,11 +14,15 @@ source-repository head     type:     darcs     subdir:   happstack-server-    location: http://patch-tag.com/r/mae/happstack/pullrepo+    location: http://patch-tag.com/r/mae/happstack  Flag base4     Description: Choose the even newer, even smaller, split-up base package. +Flag network_2_2_3+    Description: Choose newer network library with merged in network-bytestring. We can not really use this until hslogger is updated to allow it. (Or we ditch hslogger)+    Default: False+ Flag tests     Description: Build the testsuite, and include the tests in the library     Default: False@@ -27,18 +31,33 @@    Exposed-modules:                        Happstack.Server+                       Happstack.Server.Auth                        Happstack.Server.Cookie-                       Happstack.Server.HTTP.Client-                       Happstack.Server.HTTP.Types-                       Happstack.Server.HTTP.LowLevel-                       Happstack.Server.HTTP.FileServe-                       Happstack.Server.SimpleHTTP-                       Happstack.Server.MessageWrap-                       Happstack.Server.MinHaXML+                       Happstack.Server.Compression+                       Happstack.Server.Client+                       Happstack.Server.Error+                       Happstack.Server.FileServe+                       Happstack.Server.FileServe.BuildingBlocks+                       Happstack.Server.Internal.Compression+                       Happstack.Server.Internal.Cookie+                       Happstack.Server.Internal.Types+                       Happstack.Server.Internal.LowLevel+                       Happstack.Server.Internal.MessageWrap+--                       Happstack.Server.Internal.NoPush+                       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                        Happstack.Server.XSLT-                       Happstack.Server.StdConfig-                       Happstack.Server.Parts+   if flag(tests)     Exposed-modules:                           Happstack.Server.Tests@@ -46,42 +65,49 @@                        Happstack.Server.HTTPClient.HTTP                        Happstack.Server.HTTPClient.Stream                        Happstack.Server.HTTPClient.TCP-                       Happstack.Server.HTTP.Clock-                       Happstack.Server.HTTP.Handler-                       Happstack.Server.HTTP.LazyLiner-                       Happstack.Server.HTTP.Listen-                       Happstack.Server.HTTP.Multipart-                       Happstack.Server.HTTP.RFC822Headers-                       Happstack.Server.HTTP.Socket-                       Happstack.Server.HTTP.SocketTH+                       Happstack.Server.Internal.Clock+                       Happstack.Server.Internal.Handler+                       Happstack.Server.Internal.LazyLiner+                       Happstack.Server.Internal.Listen+                       Happstack.Server.Internal.Multipart+                       Happstack.Server.Internal.RFC822Headers+                       Happstack.Server.Internal.Socket+                       Happstack.Server.Internal.SocketTH                        Happstack.Server.SURI.ParseURI                        Paths_happstack_server    Build-Depends:       base,+                       blaze-html >= 0.3 && < 0.5,                        bytestring,                        containers,                        directory,                        extensible-exceptions,                        filepath,-                       HaXml >= 1.13 && < 1.14,+--                       HaXml >= 1.13 && < 1.14,                        hslogger >= 1.0.2,-                       happstack-data >= 0.5 && < 0.5.1,-                       happstack-util >= 0.5 && < 0.5.1,+                       happstack-data >= 6.0 && < 6.1,+                       happstack-util >= 6.0 && < 6.1,                        html,                        MaybeT,                        mtl >= 1.1 && < 2.1,-                       network,                        old-locale,                        old-time,                        parsec < 4,                        process,-                       sendfile >= 0.6.1 && < 0.8,+                       sendfile >= 0.7.1 && < 0.8,                        template-haskell,+                       text >= 0.10 && < 0.12,                        time,                        utf8-string >= 0.3.4 && < 0.4,                        xhtml,                        zlib+  if flag(network_2_2_3)+    Build-Depends:     network >= 2.2.3+  else+    Build-Depends:     network < 2.2.3, network-bytestring ++   hs-source-dirs:      src   if flag(tests)     hs-source-dirs:    tests@@ -100,13 +126,17 @@                        FlexibleInstances, UndecidableInstances, ScopedTypeVariables,                        TypeSynonymInstances, PatternGuards                        CPP, ForeignFunctionInterface-  ghc-options:         -Wall+  if impl(ghc >= 6.12)+     ghc-options:      -Wall -fno-warn-unused-do-bind+  else+     ghc-options:      -Wall   GHC-Prof-Options:    -auto-all  Executable happstack-server-tests   Main-Is: Test.hs   GHC-Options: -threaded   hs-source-dirs: tests, src+--  Other-modules: Happstack.Server.Internal.NoPush   if flag(tests)     Buildable: True     Build-depends: HUnit, parsec < 4

@@ -1,15 +1,91 @@+{- |+Module      :  Happstack.Server+Copyright   :  (c) Happstack.com 2010; (c) HAppS Inc 2007+License     :  BSD3++Maintainer  :  Happstack team <happs@googlegroups.com>+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: <http://localhost:8000/>++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 <http://happstack.com/docs/crashcourse/index.html>.++-} module Happstack.Server -(module Happstack.Server.XSLT-,module Happstack.Server.SimpleHTTP-,module Happstack.Server.HTTP.Client-,module Happstack.Server.MessageWrap-,module Happstack.Server.HTTP.FileServe-,module Happstack.Server.StdConfig)-where-import Happstack.Server.HTTP.Client-import Happstack.Server.StdConfig-import Happstack.Server.XSLT-import Happstack.Server.SimpleHTTP-import Happstack.Server.MessageWrap-import Happstack.Server.HTTP.FileServe+    ( -- * 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+    -- * 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+                                         , parseConfig)+import Happstack.Server.FileServe+import Happstack.Server.Monads+import Happstack.Server.Auth+import Happstack.Server.Cookie+import Happstack.Server.Error+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.Monads

@@ -0,0 +1,45 @@+{-# LANGUAGE FlexibleContexts #-}+-- | Support for basic access authentication <http://en.wikipedia.org/wiki/Basic_access_authentication>+module Happstack.Server.Auth where++import Control.Monad                             (MonadPlus(mzero, mplus))+import qualified Data.ByteString.Char8           as B+import qualified Data.Map                        as M+import qualified Happstack.Crypto.Base64         as Base64+import Happstack.Server.Monads                   (FilterMonad, ServerMonad, WebMonad, escape, getHeaderM, setHeaderM)+import Happstack.Server.Types                    (Response)+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 :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadPlus m) =>+   String -- ^ the realm name+   -> M.Map String String -- ^ the username password map+   -> m a -- ^ the part to guard+   -> m a+basicAuth realmName authMap xs = basicAuthImpl `mplus` xs+  where+    basicAuthImpl = do+        aHeader <- getHeaderM "authorization"+        case aHeader of+            Nothing -> err+            Just x -> case parseHeader x of+                (name, ':':password) | validLogin name password -> mzero+                                     | otherwise -> err+                _  -> err+    validLogin name password = M.lookup name authMap == Just password+    parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6+    headerName  = "WWW-Authenticate"+    headerValue = "Basic realm=\"" ++ realmName ++ "\""+    err = escape $ do+            setHeaderM headerName headerValue+            unauthorized $ toResponse "Not authorized"

@@ -0,0 +1,26 @@+-- | 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 <http://hackage.haskell.org/package/http-enumerator>.+module Happstack.Server.Client where++import Happstack.Server.Internal.Handler    (parseResponse, putRequest)+import Happstack.Server.Internal.Types      (Response, Request, getHeader)+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 read $ tail p+      portId = PortNumber $ toEnum $ portInt+  h <- connectTo hostName portId +  hSetBuffering h NoBuffering++  putRequest h rq+  hFlush h++  inputStr <- L.hGetContents h+  return $ parseResponse inputStr

@@ -0,0 +1,7 @@+{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}+-- | Filter for compressing the 'Response' body.+module Happstack.Server.Compression+    ( compressedResponseFilter+    ) where++import Happstack.Server.Internal.Compression (compressedResponseFilter)

@@ -1,140 +1,51 @@-{-# LANGUAGE DeriveDataTypeable #-}---- http://tools.ietf.org/html/rfc2109+{-# 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-    , mkCookieHeader-    , getCookies-    , getCookie-    , getCookies'-    , getCookie'-    , parseCookies-    , cookiesParser+    , addCookie+    , addCookies+    , expireCookie     )     where -import qualified Data.ByteString.Char8 as C-import Data.Char-import Data.List-import Data.Generics-import Happstack.Util.Common (Seconds)-import Text.ParserCombinators.Parsec hiding (token)--data Cookie = Cookie-    { cookieVersion :: String-    , cookiePath    :: String-    , cookieDomain  :: String-    , cookieName    :: String-    , cookieValue   :: String-    , secure        :: Bool-    } deriving(Show,Eq,Read,Typeable,Data)---- | Creates a cookie with a default version of 1 and path of "/"-mkCookie :: String -> String -> Cookie-mkCookie key val = Cookie "1" "/" "" key val False+import Control.Monad.Trans              (MonadIO(..))+import Data.Data                        (Data)+import Data.Typeable                    (Typeable)+import Data.Time.Clock                  (UTCTime)+import Happstack.Server.Internal.Monads (FilterMonad, composeFilter)+import Happstack.Server.Internal.Cookie (Cookie(..), CookieLife(..), calcLife, mkCookie, mkCookieHeader)+import Happstack.Server.Types           (Response, addHeader)+import Happstack.Util.Common            (Seconds) --- | 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 @\' \'@.+-- | Add the 'Cookie' to 'Response'. ----- 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.-mkCookieHeader :: Seconds -> Cookie -> String-mkCookieHeader sec cookie =-    let l = [("Domain=", cookieDomain cookie)-            ,("Max-Age=",if sec < 0 then "" else show sec)-            ,("Path=", cookiePath cookie)-            ,("Version=", s cookieVersion)]-        s f | f cookie == "" = ""-        s f   = '\"' : concatMap e (f cookie) ++ "\""-        e c | fctl c || c == '"' = ['\\',c]-            | otherwise          = [c]-    in concat $ intersperse ";" ((cookieName cookie++"="++s cookieValue):[ (k++v) | (k,v) <- l, "" /= v ] ++ if secure cookie then ["Secure"] 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-          cookie_version = cookie_special "$Version"-          cookie_path = cookie_special "$Path"-          cookie_domain = cookie_special "$Domain"-          cookie_special s = do-            string s-            cookieEq-            value-          cookieSep = ws >> oneOf ",;" >> ws-          cookieEq = ws >> char '=' >> ws-          ws = spaces-          value         = word-          word          = try (quoted_string) <|> incomp_token--          -- Parsers based on RFC 2068-          quoted_string = do-            char '"'-            r <-many (oneOf qdtext)-            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 \\ "\""---- | 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)+-- example+-- +-- > main = simpleHTTP nullConf $+-- >   do addCookie Session (mkCookie "name" "value")+-- >      ok $ "You now have a session cookie."+--+-- see also: 'addCookies'+addCookie :: (MonadIO m, FilterMonad Response m) => CookieLife -> Cookie -> m ()+addCookie life cookie =+    do l <- liftIO $ calcLife life+       (addHeaderM "Set-Cookie") $ mkCookieHeader l cookie+    where+      addHeaderM a v = composeFilter $ \res-> addHeader a v res -getCookie' :: Monad m => String -> C.ByteString -> m (Either String Cookie)-getCookie' s h = do-    cs <- getCookies' h-    return $ do -- Either-       cooks <- cs-       case filter (\x->(==)  (low s)  (cookieName x) ) cooks of-            [] -> fail "No cookie found"-            f -> return $ head f+-- | Add the list 'Cookie' to the 'Response'.+-- +-- see also: 'addCookie'+addCookies :: (MonadIO m, FilterMonad Response m) => [(CookieLife, Cookie)] -> m ()+addCookies = mapM_ (uncurry addCookie) -low :: String -> String-low = map toLower+-- | Expire the named cookie immediately and set the cookie value to @\"\"@+--+-- > main = simpleHTTP nullConf $+-- >   do expireCookie "name"+-- >      ok $ "The cookie has been expired." +expireCookie :: (MonadIO m, FilterMonad Response m) => String -> m () +expireCookie cookieName = addCookie Expired (mkCookie cookieName "")

@@ -0,0 +1,57 @@+-- | Some useful functions if you want to wrap the 'ServerPartT' monad transformer around the 'ErrorT' monad transformer. e.g., @'ServerPartT' ('ErrorT' e m) a@. This allows you to use 'throwError' and 'catchError' inside your monad.  +module Happstack.Server.Error where++import Control.Monad.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" #-}

@@ -0,0 +1,19 @@+-- | functions for serving static files from the disk+module Happstack.Server.FileServe +    ( -- * Serving Functions +      Browsing(..)+    , serveDirectory+    , serveFile+     -- * Content-Type \/ Mime-Type+     , MimeMap+     , mimeTypes+     , asContentType+     , guessContentTypeM+     -- * Index Files+    , defaultIxFiles+    -- * Deprecated+    , fileServe+    )+    where++import Happstack.Server.FileServe.BuildingBlocks

@@ -0,0 +1,671 @@+{-# 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,+     -- ** Serving a single file+     serveFile,+     serveFileUsing,+     -- * Low-Level+     sendFileResponse,     +     lazyByteStringResponse,+     strictByteStringResponse,+     filePathSendFile,+     filePathLazy,+     filePathStrict,+     -- * Content-Type \/ Mime-Type+     MimeMap,+     mimeTypes,+     asContentType,+     guessContentType,+     guessContentTypeM,+     -- * Other+     blockDotFiles,+     defaultIxFiles,+     tryIndex,+     doIndex,+     doIndex',+     doIndexLazy,+     doIndexStrict,+     fileNotFound,+     isDot+    ) where++import Control.Exception.Extensible (IOException, SomeException, Exception(fromException), bracket, handleJust)+import Control.Monad (MonadPlus(mzero), msum)+import Control.Monad.Trans (MonadIO(liftIO))+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Char8 as S+import Data.Data  (Data, Typeable)+import Data.Maybe (fromMaybe, maybe)+import           Data.Map (Map)+import qualified Data.Map as Map+import Happstack.Server.Monads     (Happstack, ServerMonad(askRq), FilterMonad, WebMonad, require)+import Happstack.Server.Response   (ToMessage(toResponse), ifModifiedSince, forbidden, ok, seeOther)+import Happstack.Server.Types      (Length(ContentLength), Request(rqPaths, rqUri), Response(SendFile), RsFlags(rsfLength), nullRsFlags, result, resultBS, setHeader)+import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, getModificationTime)+import System.FilePath ((</>), addTrailingPathSeparator, joinPath, takeExtension)+import System.IO (IOMode(ReadMode), hFileSize, hClose, openBinaryFile)+import System.Locale (defaultTimeLocale, rfc822DateFormat)+import System.Log.Logger (Priority(DEBUG), logM)+import System.Time (CalendarTime, formatCalendarTime, toCalendarTime, toUTCTime)++import           Text.Blaze                  ((!))+import qualified Text.Blaze.Html5            as H+import qualified Text.Blaze.Html5.Attributes as A++-- FIXME: why are these functions here ?++ioErrors :: SomeException -> Maybe IOException+ioErrors = fromException++errorwrapper :: (MonadIO m, MonadPlus m, FilterMonad Response m) => String -> String -> m Response+errorwrapper binarylocation loglocation+    = require getErrorLog $ \errorLog ->+      return $ toResponse errorLog+    where getErrorLog+                = handleJust ioErrors (const (return Nothing)) $+                do bintime <- getModificationTime binarylocation+                   logtime <- getModificationTime loglocation+                   if (logtime > bintime)+                     then fmap Just $ readFile loglocation+                     else return Nothing++-- * Mime-Type / Content-Type++-- |a 'Map' from file extensions to content-types+-- +-- 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 (CalendarTime, Request) -- ^ mod-time for the handle (MUST NOT be later than server's time of message origination), incoming request (used to check for if-modified-since header)+                 -> 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 0 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 (CalendarTime, 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 (CalendarTime, 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 handle  <- liftIO $ openBinaryFile fp ReadMode -- garbage collection should close this+       modtime <- liftIO $ getModificationTime fp+       count   <- liftIO $ hFileSize handle+       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 Lazy 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 $ bracket (openBinaryFile fp ReadMode) hClose 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++-- ** 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+    let safepath = filter (\x->not (null x) && x /= ".." && x /= ".") (rqPaths rq)+        fp = joinPath  (localpath:safepath)+    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 serveFn mimeFn (ixFiles++defaultIxFiles) fp+             then indexFn fp+             else do let path' = addTrailingPathSeparator (rqUri rq)+                     seeOther path' (toResponse path')+        else if fe +                then serveFileUsing serveFn mimeFn fp+                else mzero++-- | 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 (/= ".") 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.string "Directory Listing"+           H.meta  ! A.httpEquiv (H.stringValue "Content-Type") ! A.content (H.stringValue "text/html;charset=utf-8")+           H.style $ H.string $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"+                                        , "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.style $ H.string $ unlines [ "table { border-collapse: collapse; font-family: 'sans-serif'; }"+                                        , "table, th, td { border: 1px solid #98BF21; }" +                                        , "td.size { text-align: right; }"+                                        , "td.date { text-align: right; }"+                                        , "td { padding-right: 1em; padding-left: 1em; }"+                                        , "tr { background-color: white; }"+                                        , "tr.alt { background-color: #EAF2D3 }"+                                        , "th { background-color: #A7C942; color: white; font-size: 1.125em; }"+                                        ]+-}+         H.body $ do+           H.h1 $ H.string "Directory Listing"+           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 CalendarTime, Maybe Integer, EntryKind)] -- ^ list of files+meta data, see 'getMetaData'+                             -> H.Html+renderDirectoryContentsTable fps =+           H.table $ do H.thead $ do H.th $ H.string ""+                                     H.th $ H.string "Name"+                                     H.th $ H.string "Last modified"+                                     H.th $ H.string "Size"+                        H.tbody $ mapM_ mkRow (zip fps $ cycle [False, True])+    where+      mkRow :: ((FilePath, Maybe CalendarTime, Maybe Integer, EntryKind), Bool) -> H.Html+      mkRow ((fp, modTime, count, kind), alt) = +          (if alt then (! A.class_ (H.stringValue "alt")) else id) $+          H.tr $ do+                   H.td (mkKind kind)+                   H.td (H.a ! A.href (H.stringValue fp)  $ H.string fp)+                   H.td ! A.class_ (H.stringValue "date") $ (H.string $ maybe "-" (formatCalendarTime defaultTimeLocale "%d-%b-%Y %X %Z") modTime)+                   (maybe id (\c -> (! A.title (H.stringValue (show c)))) count)  (H.td ! A.class_ (H.stringValue "size") $ (H.string $ maybe "-" prettyShow count)) +      mkKind :: EntryKind -> H.Html+      mkKind File        = return ()+      mkKind Directory   = H.string "➦"+      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 CalendarTime, Maybe Integer, EntryKind)+getMetaData localPath fp =+     do let localFp = localPath </> fp+        modTime <- (fmap Just . toCalendarTime =<< getModificationTime localFp) `catch` +                   (const $ return Nothing)+        count <- do de <- doesDirectoryExist localFp+                    if de+                      then do return Nothing+                      else do bracket (openBinaryFile localFp ReadMode) hClose (fmap Just . hFileSize) +                                          `catch` (\(e :: IOException) -> return Nothing)+        kind <- do fe <- doesFileExist localFp+                   if fe+                      then return File+                      else do de <- doesDirectoryExist localFp+                              if de +                                 then return Directory+                                 else return UnknownKind+        return (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 = +    fileServe' serveFn mimeFn indexFn localPath+        where+          serveFn = filePathSendFile+          mimeFn  = guessContentTypeM mimeTypes+          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","application/x-cabal"),("%","application/x-trash"),("323","text/h323"),("3gp","video/3gpp"),("7z","application/x-7z-compressed"),("abw","application/x-abiword"),("ai","application/postscript"),("aif","audio/x-aiff"),("aifc","audio/x-aiff"),("aiff","audio/x-aiff"),("alc","chemical/x-alchemy"),("art","image/x-jg"),("asc","text/plain"),("asf","video/x-ms-asf"),("asn","chemical/x-ncbi-asn1"),("aso","chemical/x-ncbi-asn1-binary"),("asx","video/x-ms-asf"),("atom","application/atom"),("atomcat","application/atomcat+xml"),("atomsrv","application/atomserv+xml"),("au","audio/basic"),("avi","video/x-msvideo"),("b","chemical/x-molconn-Z"),("bak","application/x-trash"),("bat","application/x-msdos-program"),("bcpio","application/x-bcpio"),("bib","text/x-bibtex"),("bin","application/octet-stream"),("bmp","image/x-ms-bmp"),("boo","text/x-boo"),("book","application/x-maker"),("bsd","chemical/x-crossfire"),("c","text/x-csrc"),("c++","text/x-c++src"),("c3d","chemical/x-chem3d"),("cab","application/x-cab"),("cac","chemical/x-cache"),("cache","chemical/x-cache"),("cap","application/cap"),("cascii","chemical/x-cactvs-binary"),("cat","application/vnd.ms-pki.seccat"),("cbin","chemical/x-cactvs-binary"),("cbr","application/x-cbr"),("cbz","application/x-cbz"),("cc","text/x-c++src"),("cdf","application/x-cdf"),("cdr","image/x-coreldraw"),("cdt","image/x-coreldrawtemplate"),("cdx","chemical/x-cdx"),("cdy","application/vnd.cinderella"),("cef","chemical/x-cxf"),("cer","chemical/x-cerius"),("chm","chemical/x-chemdraw"),("chrt","application/x-kchart"),("cif","chemical/x-cif"),("class","application/java-vm"),("cls","text/x-tex"),("cmdf","chemical/x-cmdf"),("cml","chemical/x-cml"),("cod","application/vnd.rim.cod"),("com","application/x-msdos-program"),("cpa","chemical/x-compass"),("cpio","application/x-cpio"),("cpp","text/x-c++src"),("cpt","application/mac-compactpro"),("crl","application/x-pkcs7-crl"),("crt","application/x-x509-ca-cert"),("csf","chemical/x-cache-csf"),("csh","application/x-csh"),("csm","chemical/x-csml"),("csml","chemical/x-csml"),("css","text/css"),("csv","text/csv"),("ctab","chemical/x-cactvs-binary"),("ctx","chemical/x-ctx"),("cu","application/cu-seeme"),("cub","chemical/x-gaussian-cube"),("cxf","chemical/x-cxf"),("cxx","text/x-c++src"),("d","text/x-dsrc"),("dat","chemical/x-mopac-input"),("dcr","application/x-director"),("deb","application/x-debian-package"),("dif","video/dv"),("diff","text/x-diff"),("dir","application/x-director"),("djv","image/vnd.djvu"),("djvu","image/vnd.djvu"),("dl","video/dl"),("dll","application/x-msdos-program"),("dmg","application/x-apple-diskimage"),("dms","application/x-dms"),("doc","application/msword"),("dot","application/msword"),("dv","video/dv"),("dvi","application/x-dvi"),("dx","chemical/x-jcamp-dx"),("dxr","application/x-director"),("emb","chemical/x-embl-dl-nucleotide"),("embl","chemical/x-embl-dl-nucleotide"),("eml","message/rfc822"),("ent","chemical/x-ncbi-asn1-ascii"),("eps","application/postscript"),("etx","text/x-setext"),("exe","application/x-msdos-program"),("ez","application/andrew-inset"),("fb","application/x-maker"),("fbdoc","application/x-maker"),("fch","chemical/x-gaussian-checkpoint"),("fchk","chemical/x-gaussian-checkpoint"),("fig","application/x-xfig"),("flac","application/x-flac"),("fli","video/fli"),("fm","application/x-maker"),("frame","application/x-maker"),("frm","application/x-maker"),("gal","chemical/x-gaussian-log"),("gam","chemical/x-gamess-input"),("gamin","chemical/x-gamess-input"),("gau","chemical/x-gaussian-input"),("gcd","text/x-pcs-gcd"),("gcf","application/x-graphing-calculator"),("gcg","chemical/x-gcg8-sequence"),("gen","chemical/x-genbank"),("gf","application/x-tex-gf"),("gif","image/gif"),("gjc","chemical/x-gaussian-input"),("gjf","chemical/x-gaussian-input"),("gl","video/gl"),("gnumeric","application/x-gnumeric"),("gpt","chemical/x-mopac-graph"),("gsf","application/x-font"),("gsm","audio/x-gsm"),("gtar","application/x-gtar"),("h","text/x-chdr"),("h++","text/x-c++hdr"),("hdf","application/x-hdf"),("hh","text/x-c++hdr"),("hin","chemical/x-hin"),("hpp","text/x-c++hdr"),("hqx","application/mac-binhex40"),("hs","text/x-haskell"),("hta","application/hta"),("htc","text/x-component"),("htm","text/html"),("html","text/html"),("hxx","text/x-c++hdr"),("ica","application/x-ica"),("ice","x-conference/x-cooltalk"),("ico","image/x-icon"),("ics","text/calendar"),("icz","text/calendar"),("ief","image/ief"),("iges","model/iges"),("igs","model/iges"),("iii","application/x-iphone"),("inp","chemical/x-gamess-input"),("ins","application/x-internet-signup"),("iso","application/x-iso9660-image"),("isp","application/x-internet-signup"),("ist","chemical/x-isostar"),("istr","chemical/x-isostar"),("jad","text/vnd.sun.j2me.app-descriptor"),("jar","application/java-archive"),("java","text/x-java"),("jdx","chemical/x-jcamp-dx"),("jmz","application/x-jmol"),("jng","image/x-jng"),("jnlp","application/x-java-jnlp-file"),("jpe","image/jpeg"),("jpeg","image/jpeg"),("jpg","image/jpeg"),("js","application/x-javascript"),("kar","audio/midi"),("key","application/pgp-keys"),("kil","application/x-killustrator"),("kin","chemical/x-kinemage"),("kml","application/vnd.google-earth.kml+xml"),("kmz","application/vnd.google-earth.kmz"),("kpr","application/x-kpresenter"),("kpt","application/x-kpresenter"),("ksp","application/x-kspread"),("kwd","application/x-kword"),("kwt","application/x-kword"),("latex","application/x-latex"),("lha","application/x-lha"),("lhs","text/x-literate-haskell"),("lsf","video/x-la-asf"),("lsx","video/x-la-asf"),("ltx","text/x-tex"),("lyx","application/x-lyx"),("lzh","application/x-lzh"),("lzx","application/x-lzx"),("m3u","audio/mpegurl"),("m4a","audio/mpeg"),("maker","application/x-maker"),("man","application/x-troff-man"),("mcif","chemical/x-mmcif"),("mcm","chemical/x-macmolecule"),("mdb","application/msaccess"),("me","application/x-troff-me"),("mesh","model/mesh"),("mid","audio/midi"),("midi","audio/midi"),("mif","application/x-mif"),("mm","application/x-freemind"),("mmd","chemical/x-macromodel-input"),("mmf","application/vnd.smaf"),("mml","text/mathml"),("mmod","chemical/x-macromodel-input"),("mng","video/x-mng"),("moc","text/x-moc"),("mol","chemical/x-mdl-molfile"),("mol2","chemical/x-mol2"),("moo","chemical/x-mopac-out"),("mop","chemical/x-mopac-input"),("mopcrt","chemical/x-mopac-input"),("mov","video/quicktime"),("movie","video/x-sgi-movie"),("mp2","audio/mpeg"),("mp3","audio/mpeg"),("mp4","video/mp4"),("mpc","chemical/x-mopac-input"),("mpe","video/mpeg"),("mpeg","video/mpeg"),("mpega","audio/mpeg"),("mpg","video/mpeg"),("mpga","audio/mpeg"),("ms","application/x-troff-ms"),("msh","model/mesh"),("msi","application/x-msi"),("mvb","chemical/x-mopac-vib"),("mxu","video/vnd.mpegurl"),("nb","application/mathematica"),("nc","application/x-netcdf"),("nwc","application/x-nwc"),("o","application/x-object"),("oda","application/oda"),("odb","application/vnd.oasis.opendocument.database"),("odc","application/vnd.oasis.opendocument.chart"),("odf","application/vnd.oasis.opendocument.formula"),("odg","application/vnd.oasis.opendocument.graphics"),("odi","application/vnd.oasis.opendocument.image"),("odm","application/vnd.oasis.opendocument.text-master"),("odp","application/vnd.oasis.opendocument.presentation"),("ods","application/vnd.oasis.opendocument.spreadsheet"),("odt","application/vnd.oasis.opendocument.text"),("oga","audio/ogg"),("ogg","application/ogg"),("ogv","video/ogg"),("ogx","application/ogg"),("old","application/x-trash"),("otg","application/vnd.oasis.opendocument.graphics-template"),("oth","application/vnd.oasis.opendocument.text-web"),("otp","application/vnd.oasis.opendocument.presentation-template"),("ots","application/vnd.oasis.opendocument.spreadsheet-template"),("ott","application/vnd.oasis.opendocument.text-template"),("oza","application/x-oz-application"),("p","text/x-pascal"),("p7r","application/x-pkcs7-certreqresp"),("pac","application/x-ns-proxy-autoconfig"),("pas","text/x-pascal"),("pat","image/x-coreldrawpattern"),("patch","text/x-diff"),("pbm","image/x-portable-bitmap"),("pcap","application/cap"),("pcf","application/x-font"),("pcf.Z","application/x-font"),("pcx","image/pcx"),("pdb","chemical/x-pdb"),("pdf","application/pdf"),("pfa","application/x-font"),("pfb","application/x-font"),("pgm","image/x-portable-graymap"),("pgn","application/x-chess-pgn"),("pgp","application/pgp-signature"),("php","application/x-httpd-php"),("php3","application/x-httpd-php3"),("php3p","application/x-httpd-php3-preprocessed"),("php4","application/x-httpd-php4"),("phps","application/x-httpd-php-source"),("pht","application/x-httpd-php"),("phtml","application/x-httpd-php"),("pk","application/x-tex-pk"),("pl","text/x-perl"),("pls","audio/x-scpls"),("pm","text/x-perl"),("png","image/png"),("pnm","image/x-portable-anymap"),("pot","text/plain"),("ppm","image/x-portable-pixmap"),("pps","application/vnd.ms-powerpoint"),("ppt","application/vnd.ms-powerpoint"),("prf","application/pics-rules"),("prt","chemical/x-ncbi-asn1-ascii"),("ps","application/postscript"),("psd","image/x-photoshop"),("py","text/x-python"),("pyc","application/x-python-code"),("pyo","application/x-python-code"),("qt","video/quicktime"),("qtl","application/x-quicktimeplayer"),("ra","audio/x-pn-realaudio"),("ram","audio/x-pn-realaudio"),("rar","application/rar"),("ras","image/x-cmu-raster"),("rd","chemical/x-mdl-rdfile"),("rdf","application/rdf+xml"),("rgb","image/x-rgb"),("rhtml","application/x-httpd-eruby"),("rm","audio/x-pn-realaudio"),("roff","application/x-troff"),("ros","chemical/x-rosdal"),("rpm","application/x-redhat-package-manager"),("rss","application/rss+xml"),("rtf","application/rtf"),("rtx","text/richtext"),("rxn","chemical/x-mdl-rxnfile"),("sct","text/scriptlet"),("sd","chemical/x-mdl-sdfile"),("sd2","audio/x-sd2"),("sda","application/vnd.stardivision.draw"),("sdc","application/vnd.stardivision.calc"),("sdd","application/vnd.stardivision.impress"),("sdf","application/vnd.stardivision.math"),("sds","application/vnd.stardivision.chart"),("sdw","application/vnd.stardivision.writer"),("ser","application/java-serialized-object"),("sgf","application/x-go-sgf"),("sgl","application/vnd.stardivision.writer-global"),("sh","application/x-sh"),("shar","application/x-shar"),("shtml","text/html"),("sid","audio/prs.sid"),("sik","application/x-trash"),("silo","model/mesh"),("sis","application/vnd.symbian.install"),("sisx","x-epoc/x-sisx-app"),("sit","application/x-stuffit"),("sitx","application/x-stuffit"),("skd","application/x-koan"),("skm","application/x-koan"),("skp","application/x-koan"),("skt","application/x-koan"),("smi","application/smil"),("smil","application/smil"),("snd","audio/basic"),("spc","chemical/x-galactic-spc"),("spl","application/futuresplash"),("spx","audio/ogg"),("src","application/x-wais-source"),("stc","application/vnd.sun.xml.calc.template"),("std","application/vnd.sun.xml.draw.template"),("sti","application/vnd.sun.xml.impress.template"),("stl","application/vnd.ms-pki.stl"),("stw","application/vnd.sun.xml.writer.template"),("sty","text/x-tex"),("sv4cpio","application/x-sv4cpio"),("sv4crc","application/x-sv4crc"),("svg","image/svg+xml"),("svgz","image/svg+xml"),("sw","chemical/x-swissprot"),("swf","application/x-shockwave-flash"),("swfl","application/x-shockwave-flash"),("sxc","application/vnd.sun.xml.calc"),("sxd","application/vnd.sun.xml.draw"),("sxg","application/vnd.sun.xml.writer.global"),("sxi","application/vnd.sun.xml.impress"),("sxm","application/vnd.sun.xml.math"),("sxw","application/vnd.sun.xml.writer"),("t","application/x-troff"),("tar","application/x-tar"),("taz","application/x-gtar"),("tcl","application/x-tcl"),("tex","text/x-tex"),("texi","application/x-texinfo"),("texinfo","application/x-texinfo"),("text","text/plain"),("tgf","chemical/x-mdl-tgf"),("tgz","application/x-gtar"),("tif","image/tiff"),("tiff","image/tiff"),("tk","text/x-tcl"),("tm","text/texmacs"),("torrent","application/x-bittorrent"),("tr","application/x-troff"),("ts","text/texmacs"),("tsp","application/dsptype"),("tsv","text/tab-separated-values"),("txt","text/plain"),("udeb","application/x-debian-package"),("uls","text/iuls"),("ustar","application/x-ustar"),("val","chemical/x-ncbi-asn1-binary"),("vcd","application/x-cdlink"),("vcf","text/x-vcard"),("vcs","text/x-vcalendar"),("vmd","chemical/x-vmd"),("vms","chemical/x-vamas-iso14976"),("vrm","x-world/x-vrml"),("vrml","model/vrml"),("vsd","application/vnd.visio"),("wad","application/x-doom"),("wav","audio/x-wav"),("wax","audio/x-ms-wax"),("wbmp","image/vnd.wap.wbmp"),("wbxml","application/vnd.wap.wbxml"),("wk","application/x-123"),("wm","video/x-ms-wm"),("wma","audio/x-ms-wma"),("wmd","application/x-ms-wmd"),("wml","text/vnd.wap.wml"),("wmlc","application/vnd.wap.wmlc"),("wmls","text/vnd.wap.wmlscript"),("wmlsc","application/vnd.wap.wmlscriptc"),("wmv","video/x-ms-wmv"),("wmx","video/x-ms-wmx"),("wmz","application/x-ms-wmz"),("wp5","application/wordperfect5.1"),("wpd","application/wordperfect"),("wrl","model/vrml"),("wsc","text/scriptlet"),("wvx","video/x-ms-wvx"),("wz","application/x-wingz"),("xbm","image/x-xbitmap"),("xcf","application/x-xcf"),("xht","application/xhtml+xml"),("xhtml","application/xhtml+xml"),("xlb","application/vnd.ms-excel"),("xls","application/vnd.ms-excel"),("xlt","application/vnd.ms-excel"),("xml","application/xml"),("xpi","application/x-xpinstall"),("xpm","image/x-xpixmap"),("xsl","application/xml"),("xtel","chemical/x-xtel"),("xul","application/vnd.mozilla.xul+xml"),("xwd","image/x-xwindowdump"),("xyz","chemical/x-xyz"),("zip","application/zip"),("zmt","chemical/x-mopac-input"),("~","application/x-trash")]+

@@ -1,53 +0,0 @@-module Happstack.Server.HTTP.Client where---import Happstack.Server.HTTP.Handler-import Happstack.Server.HTTP.Types-import Data.Maybe-import Control.Monad-import qualified Data.ByteString.Lazy.Char8 as L --import System.IO-import qualified Data.ByteString.Char8 as B -import Network---- | 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 read $ tail p-      portId = PortNumber $ toEnum $ portInt-  h <- connectTo hostName portId -  hSetBuffering h NoBuffering--  putRequest h rq-  hFlush h--  inputStr <- L.hGetContents h-  return $ parseResponse inputStr--unproxify :: Request -> Request-unproxify rq = rq {rqPaths = tail $ rqPaths rq,-                   rqHeaders = -                       forwardedFor $ forwardedHost $ -                       setHeader "host" (head $ rqPaths rq) $-                   rqHeaders rq}-  where-  appendInfo hdr val = setHeader hdr (csv val $-                                        maybe "" B.unpack $-                                        getHeader hdr rq)-  forwardedFor = appendInfo "X-Forwarded-For" (fst $ rqPeer rq)-  forwardedHost = appendInfo "X-Forwarded-Host" -                  (B.unpack $ fromJust $ getHeader "host" rq)-  csv v "" = v-  csv v x = x++", " ++ v--unrproxify :: String -> [(String, String)] -> Request -> Request-unrproxify defaultHost list rq = -  let host::String-      host = fromMaybe defaultHost $ flip lookup list =<< B.unpack `liftM` getHeader "host" rq -      newrq = rq {rqPaths = host: rqPaths rq}-  in  unproxify newrq--

@@ -1,30 +0,0 @@-{-# OPTIONS -fno-cse #-}-module Happstack.Server.HTTP.Clock(getApproximateTime) where--import Control.Concurrent-import Data.IORef-import System.IO.Unsafe-import System.Time-import System.Locale--import qualified Data.ByteString.Char8 as B--mkTime :: IO B.ByteString-mkTime = do now <- getClockTime-            return $ B.pack (formatCalendarTime defaultTimeLocale "%a, %d %b %Y %X GMT" (toUTCTime now))---{-# NOINLINE clock #-}-clock :: IORef B.ByteString-clock = unsafePerformIO $ do-  ref <- newIORef =<< mkTime-  forkIO $ updater ref-  return ref--updater :: IORef B.ByteString -> IO ()-updater ref = do threadDelay (10^(6 :: Int)) -- Every second-                 writeIORef ref =<< mkTime-                 updater ref--getApproximateTime :: IO B.ByteString-getApproximateTime = readIORef clock

@@ -1,354 +0,0 @@-{-# LANGUAGE FlexibleContexts, Rank2Types #-}--- |File Serving functions-module Happstack.Server.HTTP.FileServe-    (-     -- * Content-Type \/ Mime-Type-     MimeMap,-     mimeTypes,-     asContentType,-     guessContentType,-     guessContentTypeM,-     -- * Low-Level-     sendFileResponse,     -     lazyByteStringResponse,-     strictByteStringResponse,-     filePathSendFile,-     filePathLazy,-     filePathStrict,-     -- * High-Level-     -- ** Serving a single file-     serveFile,-     serveFileUsing,-     -- ** Serving files from a directory-     fileServe',-     fileServe,-     fileServeLazy,-     fileServeStrict,-     -- * Other-     blockDotFiles,-     defaultIxFiles,-     doIndex,-     doIndex',-     doIndexLazy,-     doIndexStrict,-     errorwrapper,-     fileNotFound,-     isDot-    ) where--import Control.Exception.Extensible (IOException, SomeException, Exception(fromException), bracket, handleJust)-import Control.Monad (MonadPlus(mzero))-import Control.Monad.Trans (MonadIO(liftIO))-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Char8 as S-import Data.Maybe (fromMaybe)-import           Data.Map (Map)-import qualified Data.Map as Map-import Happstack.Server.SimpleHTTP (FilterMonad, ServerMonad(askRq), Request(..), Response(..), WebMonad, toResponse, resultBS, setHeader, forbidden, nullRsFlags, result, require, rsfContentLength, seeOther, ifModifiedSince )-import System.Directory (doesDirectoryExist, doesFileExist, getModificationTime)-import System.IO (IOMode(ReadMode), hFileSize, hClose, openBinaryFile)-import System.FilePath ((</>), addTrailingPathSeparator, joinPath, takeExtension)-import System.Log.Logger (Priority(DEBUG), logM)-import System.Time (CalendarTime, toUTCTime)--ioErrors :: SomeException -> Maybe IOException-ioErrors = fromException--errorwrapper :: (MonadIO m, MonadPlus m, FilterMonad Response m) => String -> String -> m Response-errorwrapper binarylocation loglocation-    = require getErrorLog $ \errorLog ->-      return $ toResponse errorLog-    where getErrorLog-                = handleJust ioErrors (const (return Nothing)) $-                do bintime <- getModificationTime binarylocation-                   logtime <- getModificationTime loglocation-                   if (logtime > bintime)-                     then fmap Just $ readFile loglocation-                     else return Nothing---- * Mime-Type / Content-Type--type MimeMap = Map String String---- | 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","application/x-cabal"),("%","application/x-trash"),("323","text/h323"),("3gp","video/3gpp"),("7z","application/x-7z-compressed"),("abw","application/x-abiword"),("ai","application/postscript"),("aif","audio/x-aiff"),("aifc","audio/x-aiff"),("aiff","audio/x-aiff"),("alc","chemical/x-alchemy"),("art","image/x-jg"),("asc","text/plain"),("asf","video/x-ms-asf"),("asn","chemical/x-ncbi-asn1"),("aso","chemical/x-ncbi-asn1-binary"),("asx","video/x-ms-asf"),("atom","application/atom"),("atomcat","application/atomcat+xml"),("atomsrv","application/atomserv+xml"),("au","audio/basic"),("avi","video/x-msvideo"),("b","chemical/x-molconn-Z"),("bak","application/x-trash"),("bat","application/x-msdos-program"),("bcpio","application/x-bcpio"),("bib","text/x-bibtex"),("bin","application/octet-stream"),("bmp","image/x-ms-bmp"),("boo","text/x-boo"),("book","application/x-maker"),("bsd","chemical/x-crossfire"),("c","text/x-csrc"),("c++","text/x-c++src"),("c3d","chemical/x-chem3d"),("cab","application/x-cab"),("cac","chemical/x-cache"),("cache","chemical/x-cache"),("cap","application/cap"),("cascii","chemical/x-cactvs-binary"),("cat","application/vnd.ms-pki.seccat"),("cbin","chemical/x-cactvs-binary"),("cbr","application/x-cbr"),("cbz","application/x-cbz"),("cc","text/x-c++src"),("cdf","application/x-cdf"),("cdr","image/x-coreldraw"),("cdt","image/x-coreldrawtemplate"),("cdx","chemical/x-cdx"),("cdy","application/vnd.cinderella"),("cef","chemical/x-cxf"),("cer","chemical/x-cerius"),("chm","chemical/x-chemdraw"),("chrt","application/x-kchart"),("cif","chemical/x-cif"),("class","application/java-vm"),("cls","text/x-tex"),("cmdf","chemical/x-cmdf"),("cml","chemical/x-cml"),("cod","application/vnd.rim.cod"),("com","application/x-msdos-program"),("cpa","chemical/x-compass"),("cpio","application/x-cpio"),("cpp","text/x-c++src"),("cpt","application/mac-compactpro"),("crl","application/x-pkcs7-crl"),("crt","application/x-x509-ca-cert"),("csf","chemical/x-cache-csf"),("csh","application/x-csh"),("csm","chemical/x-csml"),("csml","chemical/x-csml"),("css","text/css"),("csv","text/csv"),("ctab","chemical/x-cactvs-binary"),("ctx","chemical/x-ctx"),("cu","application/cu-seeme"),("cub","chemical/x-gaussian-cube"),("cxf","chemical/x-cxf"),("cxx","text/x-c++src"),("d","text/x-dsrc"),("dat","chemical/x-mopac-input"),("dcr","application/x-director"),("deb","application/x-debian-package"),("dif","video/dv"),("diff","text/x-diff"),("dir","application/x-director"),("djv","image/vnd.djvu"),("djvu","image/vnd.djvu"),("dl","video/dl"),("dll","application/x-msdos-program"),("dmg","application/x-apple-diskimage"),("dms","application/x-dms"),("doc","application/msword"),("dot","application/msword"),("dv","video/dv"),("dvi","application/x-dvi"),("dx","chemical/x-jcamp-dx"),("dxr","application/x-director"),("emb","chemical/x-embl-dl-nucleotide"),("embl","chemical/x-embl-dl-nucleotide"),("eml","message/rfc822"),("ent","chemical/x-ncbi-asn1-ascii"),("eps","application/postscript"),("etx","text/x-setext"),("exe","application/x-msdos-program"),("ez","application/andrew-inset"),("fb","application/x-maker"),("fbdoc","application/x-maker"),("fch","chemical/x-gaussian-checkpoint"),("fchk","chemical/x-gaussian-checkpoint"),("fig","application/x-xfig"),("flac","application/x-flac"),("fli","video/fli"),("fm","application/x-maker"),("frame","application/x-maker"),("frm","application/x-maker"),("gal","chemical/x-gaussian-log"),("gam","chemical/x-gamess-input"),("gamin","chemical/x-gamess-input"),("gau","chemical/x-gaussian-input"),("gcd","text/x-pcs-gcd"),("gcf","application/x-graphing-calculator"),("gcg","chemical/x-gcg8-sequence"),("gen","chemical/x-genbank"),("gf","application/x-tex-gf"),("gif","image/gif"),("gjc","chemical/x-gaussian-input"),("gjf","chemical/x-gaussian-input"),("gl","video/gl"),("gnumeric","application/x-gnumeric"),("gpt","chemical/x-mopac-graph"),("gsf","application/x-font"),("gsm","audio/x-gsm"),("gtar","application/x-gtar"),("h","text/x-chdr"),("h++","text/x-c++hdr"),("hdf","application/x-hdf"),("hh","text/x-c++hdr"),("hin","chemical/x-hin"),("hpp","text/x-c++hdr"),("hqx","application/mac-binhex40"),("hs","text/x-haskell"),("hta","application/hta"),("htc","text/x-component"),("htm","text/html"),("html","text/html"),("hxx","text/x-c++hdr"),("ica","application/x-ica"),("ice","x-conference/x-cooltalk"),("ico","image/x-icon"),("ics","text/calendar"),("icz","text/calendar"),("ief","image/ief"),("iges","model/iges"),("igs","model/iges"),("iii","application/x-iphone"),("inp","chemical/x-gamess-input"),("ins","application/x-internet-signup"),("iso","application/x-iso9660-image"),("isp","application/x-internet-signup"),("ist","chemical/x-isostar"),("istr","chemical/x-isostar"),("jad","text/vnd.sun.j2me.app-descriptor"),("jar","application/java-archive"),("java","text/x-java"),("jdx","chemical/x-jcamp-dx"),("jmz","application/x-jmol"),("jng","image/x-jng"),("jnlp","application/x-java-jnlp-file"),("jpe","image/jpeg"),("jpeg","image/jpeg"),("jpg","image/jpeg"),("js","application/x-javascript"),("kar","audio/midi"),("key","application/pgp-keys"),("kil","application/x-killustrator"),("kin","chemical/x-kinemage"),("kml","application/vnd.google-earth.kml+xml"),("kmz","application/vnd.google-earth.kmz"),("kpr","application/x-kpresenter"),("kpt","application/x-kpresenter"),("ksp","application/x-kspread"),("kwd","application/x-kword"),("kwt","application/x-kword"),("latex","application/x-latex"),("lha","application/x-lha"),("lhs","text/x-literate-haskell"),("lsf","video/x-la-asf"),("lsx","video/x-la-asf"),("ltx","text/x-tex"),("lyx","application/x-lyx"),("lzh","application/x-lzh"),("lzx","application/x-lzx"),("m3u","audio/mpegurl"),("m4a","audio/mpeg"),("maker","application/x-maker"),("man","application/x-troff-man"),("mcif","chemical/x-mmcif"),("mcm","chemical/x-macmolecule"),("mdb","application/msaccess"),("me","application/x-troff-me"),("mesh","model/mesh"),("mid","audio/midi"),("midi","audio/midi"),("mif","application/x-mif"),("mm","application/x-freemind"),("mmd","chemical/x-macromodel-input"),("mmf","application/vnd.smaf"),("mml","text/mathml"),("mmod","chemical/x-macromodel-input"),("mng","video/x-mng"),("moc","text/x-moc"),("mol","chemical/x-mdl-molfile"),("mol2","chemical/x-mol2"),("moo","chemical/x-mopac-out"),("mop","chemical/x-mopac-input"),("mopcrt","chemical/x-mopac-input"),("mov","video/quicktime"),("movie","video/x-sgi-movie"),("mp2","audio/mpeg"),("mp3","audio/mpeg"),("mp4","video/mp4"),("mpc","chemical/x-mopac-input"),("mpe","video/mpeg"),("mpeg","video/mpeg"),("mpega","audio/mpeg"),("mpg","video/mpeg"),("mpga","audio/mpeg"),("ms","application/x-troff-ms"),("msh","model/mesh"),("msi","application/x-msi"),("mvb","chemical/x-mopac-vib"),("mxu","video/vnd.mpegurl"),("nb","application/mathematica"),("nc","application/x-netcdf"),("nwc","application/x-nwc"),("o","application/x-object"),("oda","application/oda"),("odb","application/vnd.oasis.opendocument.database"),("odc","application/vnd.oasis.opendocument.chart"),("odf","application/vnd.oasis.opendocument.formula"),("odg","application/vnd.oasis.opendocument.graphics"),("odi","application/vnd.oasis.opendocument.image"),("odm","application/vnd.oasis.opendocument.text-master"),("odp","application/vnd.oasis.opendocument.presentation"),("ods","application/vnd.oasis.opendocument.spreadsheet"),("odt","application/vnd.oasis.opendocument.text"),("oga","audio/ogg"),("ogg","application/ogg"),("ogv","video/ogg"),("ogx","application/ogg"),("old","application/x-trash"),("otg","application/vnd.oasis.opendocument.graphics-template"),("oth","application/vnd.oasis.opendocument.text-web"),("otp","application/vnd.oasis.opendocument.presentation-template"),("ots","application/vnd.oasis.opendocument.spreadsheet-template"),("ott","application/vnd.oasis.opendocument.text-template"),("oza","application/x-oz-application"),("p","text/x-pascal"),("p7r","application/x-pkcs7-certreqresp"),("pac","application/x-ns-proxy-autoconfig"),("pas","text/x-pascal"),("pat","image/x-coreldrawpattern"),("patch","text/x-diff"),("pbm","image/x-portable-bitmap"),("pcap","application/cap"),("pcf","application/x-font"),("pcf.Z","application/x-font"),("pcx","image/pcx"),("pdb","chemical/x-pdb"),("pdf","application/pdf"),("pfa","application/x-font"),("pfb","application/x-font"),("pgm","image/x-portable-graymap"),("pgn","application/x-chess-pgn"),("pgp","application/pgp-signature"),("php","application/x-httpd-php"),("php3","application/x-httpd-php3"),("php3p","application/x-httpd-php3-preprocessed"),("php4","application/x-httpd-php4"),("phps","application/x-httpd-php-source"),("pht","application/x-httpd-php"),("phtml","application/x-httpd-php"),("pk","application/x-tex-pk"),("pl","text/x-perl"),("pls","audio/x-scpls"),("pm","text/x-perl"),("png","image/png"),("pnm","image/x-portable-anymap"),("pot","text/plain"),("ppm","image/x-portable-pixmap"),("pps","application/vnd.ms-powerpoint"),("ppt","application/vnd.ms-powerpoint"),("prf","application/pics-rules"),("prt","chemical/x-ncbi-asn1-ascii"),("ps","application/postscript"),("psd","image/x-photoshop"),("py","text/x-python"),("pyc","application/x-python-code"),("pyo","application/x-python-code"),("qt","video/quicktime"),("qtl","application/x-quicktimeplayer"),("ra","audio/x-pn-realaudio"),("ram","audio/x-pn-realaudio"),("rar","application/rar"),("ras","image/x-cmu-raster"),("rd","chemical/x-mdl-rdfile"),("rdf","application/rdf+xml"),("rgb","image/x-rgb"),("rhtml","application/x-httpd-eruby"),("rm","audio/x-pn-realaudio"),("roff","application/x-troff"),("ros","chemical/x-rosdal"),("rpm","application/x-redhat-package-manager"),("rss","application/rss+xml"),("rtf","application/rtf"),("rtx","text/richtext"),("rxn","chemical/x-mdl-rxnfile"),("sct","text/scriptlet"),("sd","chemical/x-mdl-sdfile"),("sd2","audio/x-sd2"),("sda","application/vnd.stardivision.draw"),("sdc","application/vnd.stardivision.calc"),("sdd","application/vnd.stardivision.impress"),("sdf","application/vnd.stardivision.math"),("sds","application/vnd.stardivision.chart"),("sdw","application/vnd.stardivision.writer"),("ser","application/java-serialized-object"),("sgf","application/x-go-sgf"),("sgl","application/vnd.stardivision.writer-global"),("sh","application/x-sh"),("shar","application/x-shar"),("shtml","text/html"),("sid","audio/prs.sid"),("sik","application/x-trash"),("silo","model/mesh"),("sis","application/vnd.symbian.install"),("sisx","x-epoc/x-sisx-app"),("sit","application/x-stuffit"),("sitx","application/x-stuffit"),("skd","application/x-koan"),("skm","application/x-koan"),("skp","application/x-koan"),("skt","application/x-koan"),("smi","application/smil"),("smil","application/smil"),("snd","audio/basic"),("spc","chemical/x-galactic-spc"),("spl","application/futuresplash"),("spx","audio/ogg"),("src","application/x-wais-source"),("stc","application/vnd.sun.xml.calc.template"),("std","application/vnd.sun.xml.draw.template"),("sti","application/vnd.sun.xml.impress.template"),("stl","application/vnd.ms-pki.stl"),("stw","application/vnd.sun.xml.writer.template"),("sty","text/x-tex"),("sv4cpio","application/x-sv4cpio"),("sv4crc","application/x-sv4crc"),("svg","image/svg+xml"),("svgz","image/svg+xml"),("sw","chemical/x-swissprot"),("swf","application/x-shockwave-flash"),("swfl","application/x-shockwave-flash"),("sxc","application/vnd.sun.xml.calc"),("sxd","application/vnd.sun.xml.draw"),("sxg","application/vnd.sun.xml.writer.global"),("sxi","application/vnd.sun.xml.impress"),("sxm","application/vnd.sun.xml.math"),("sxw","application/vnd.sun.xml.writer"),("t","application/x-troff"),("tar","application/x-tar"),("taz","application/x-gtar"),("tcl","application/x-tcl"),("tex","text/x-tex"),("texi","application/x-texinfo"),("texinfo","application/x-texinfo"),("text","text/plain"),("tgf","chemical/x-mdl-tgf"),("tgz","application/x-gtar"),("tif","image/tiff"),("tiff","image/tiff"),("tk","text/x-tcl"),("tm","text/texmacs"),("torrent","application/x-bittorrent"),("tr","application/x-troff"),("ts","text/texmacs"),("tsp","application/dsptype"),("tsv","text/tab-separated-values"),("txt","text/plain"),("udeb","application/x-debian-package"),("uls","text/iuls"),("ustar","application/x-ustar"),("val","chemical/x-ncbi-asn1-binary"),("vcd","application/x-cdlink"),("vcf","text/x-vcard"),("vcs","text/x-vcalendar"),("vmd","chemical/x-vmd"),("vms","chemical/x-vamas-iso14976"),("vrm","x-world/x-vrml"),("vrml","model/vrml"),("vsd","application/vnd.visio"),("wad","application/x-doom"),("wav","audio/x-wav"),("wax","audio/x-ms-wax"),("wbmp","image/vnd.wap.wbmp"),("wbxml","application/vnd.wap.wbxml"),("wk","application/x-123"),("wm","video/x-ms-wm"),("wma","audio/x-ms-wma"),("wmd","application/x-ms-wmd"),("wml","text/vnd.wap.wml"),("wmlc","application/vnd.wap.wmlc"),("wmls","text/vnd.wap.wmlscript"),("wmlsc","application/vnd.wap.wmlscriptc"),("wmv","video/x-ms-wmv"),("wmx","video/x-ms-wmx"),("wmz","application/x-ms-wmz"),("wp5","application/wordperfect5.1"),("wpd","application/wordperfect"),("wrl","model/vrml"),("wsc","text/scriptlet"),("wvx","video/x-ms-wvx"),("wz","application/x-wingz"),("xbm","image/x-xbitmap"),("xcf","application/x-xcf"),("xht","application/xhtml+xml"),("xhtml","application/xhtml+xml"),("xlb","application/vnd.ms-excel"),("xls","application/vnd.ms-excel"),("xlt","application/vnd.ms-excel"),("xml","application/xml"),("xpi","application/x-xpinstall"),("xpm","image/x-xpixmap"),("xsl","application/xml"),("xtel","chemical/x-xtel"),("xul","application/vnd.mozilla.xul+xml"),("xwd","image/x-xwindowdump"),("xyz","chemical/x-xyz"),("zip","application/zip"),("zmt","chemical/x-mopac-input"),("~","application/x-trash")]---guessContentType :: MimeMap -> FilePath -> Maybe String-guessContentType mimeMap filepath =-    case getExt filepath of-      "" -> Nothing-      ext -> Map.lookup ext mimeMap--guessContentTypeM :: (Monad m) => MimeMap -> (FilePath -> m String)-guessContentTypeM mimeMap filePath = return $ fromMaybe "text/plain" $ guessContentType mimeMap filePath--asContentType :: (Monad m) => String -> (FilePath -> m String)-asContentType = const . return--defaultIxFiles :: [String]-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 (CalendarTime, Request) -- ^ mod-time for the handle (MUST NOT be later than server's time of message origination), incoming request (used to check for if-modified-since header)-                 -> Integer -- ^ offset into Handle-                 -> Integer -- ^ number of bytes to send-                 -> Response-sendFileResponse ct filePath mModTime _offset count =-    let res = ((setHeader "Content-Length" (show count)) .-               (setHeader "Content-Type" ct) $ -               (SendFile 200 Map.empty nullRsFlags{rsfContentLength=False} Nothing filePath 0 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 (CalendarTime, 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 (CalendarTime, 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 handle  <- liftIO $ openBinaryFile fp ReadMode -- garbage collection should close this-       modtime <- liftIO $ getModificationTime fp-       count   <- liftIO $ hFileSize handle-       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 Lazy 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 $ bracket (openBinaryFile fp ReadMode) hClose 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.--- --- 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---- | Alias for 'serveFileUsing' 'filePathSendFile'-serveFile :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => (FilePath -> m String) -> FilePath -> m Response-serveFile = serveFileUsing filePathSendFile---- ** 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           -- ^ file/directory to serve-           -> m Response-fileServe' serveFn mimeFn ixFiles localpath = do-    rq <- askRq-    let safepath = filter (\x->not (null x) && x /= ".." && x /= ".") (rqPaths rq)-        fp = joinPath  (localpath:safepath)-    fe <- liftIO $ doesFileExist fp-    de <- liftIO $ doesDirectoryExist fp-    let status | de   = "DIR"-               | fe   = "file"-               | True = "NOT FOUND"-    liftIO $ logM "Happstack.Server.HTTP.FileServe" DEBUG ("fileServe: "++show fp++" \t"++status)-    if de-        then if last (rqUri rq) == '/'-             then doIndex' serveFn mimeFn (ixFiles++defaultIxFiles) fp-             else do let path' = addTrailingPathSeparator (rqUri rq)-                     seeOther path' (toResponse path')-        else if fe -                then serveFileUsing serveFn mimeFn fp-                else mzero---- | Serve files from a directory and its subdirectories (sendFile version). Should perform much better than its predecessors.-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' filePathSendFile (guessContentTypeM mimeTypes) (ixFiles ++ defaultIxFiles) localPath---- | Serve files from a directory and its subdirectories (lazy ByteString version).--- --- May leak file handles.-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' filePathLazy (guessContentTypeM mimeTypes) (ixFiles ++ defaultIxFiles) localPath---- | Serve files from a directory and its subdirectories (strict ByteString version). -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' filePathStrict (guessContentTypeM mimeTypes) (ixFiles ++ defaultIxFiles) localPath---- * Index--doIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m)-        => [String]-        -> MimeMap-        -> String-        -> m Response-doIndex ixFiles mimeMap localPath = doIndex' filePathSendFile (guessContentTypeM mimeMap) ixFiles localPath--doIndexLazy :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m)-        => [String]-        -> MimeMap-        -> String-        -> m Response-doIndexLazy ixFiles mimeMap localPath = doIndex' filePathLazy (guessContentTypeM mimeMap) ixFiles localPath--doIndexStrict :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m)-        => [String]-        -> MimeMap-        -> String-        -> 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]-        -> String-        -> m Response-doIndex' _serveFn _mime  []          _fp = forbidden $ toResponse "Directory index forbidden"-doIndex'  serveFn mimeFn (index:rest) fp =-    do let path = fp </> index-       fe <- liftIO $ doesFileExist path-       if fe -          then serveFileUsing serveFn mimeFn path -          else doIndex' serveFn mimeFn rest fp

@@ -1,365 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables #-}--module Happstack.Server.HTTP.Handler(request-- version,required-  ,parseResponse,putRequest--- ,unchunkBody,val,testChunk,pack-) where---    ,fsepC,crlfC,pversion-import qualified Paths_happstack_server as Paths-import qualified Data.Version as DV-import Control.Exception.Extensible as E-import Control.Monad-import Data.List(elemIndex)-import Data.Char(toLower)-import Data.Maybe ( fromMaybe, fromJust, isJust, isNothing )-import Prelude hiding (last)-import qualified Data.List as List-import qualified Data.ByteString.Char8 as P-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Lazy.Internal as L-import qualified Data.ByteString.Internal as S-import qualified Data.ByteString.Unsafe as S-import qualified Data.ByteString as S-import System.IO.Unsafe-import qualified Data.Map as M-import System.IO-import Numeric-import Data.Int (Int64)-import Happstack.Server.Cookie-import Happstack.Server.HTTP.Clock-import Happstack.Server.HTTP.Types-import Happstack.Server.HTTP.Multipart-import Happstack.Server.HTTP.RFC822Headers-import Happstack.Server.MessageWrap-import Happstack.Server.SURI(SURI(..),path,query)-import Happstack.Server.SURI.ParseURI-import Happstack.Util.TimeOut-import Happstack.Util.LogFormat (formatRequestCombined)-import Data.Time.Clock (getCurrentTime)-import Network.Socket.SendFile (unsafeSendFile')-import System.Log.Logger (Priority(..), logM)---hGetContentsN :: Int -> Handle -> IO L.ByteString-hGetContentsN k h = lazyRead -- TODO close on exceptions-  where-    lazyRead = unsafeInterleaveIO loop--    loop = do-        c <- S.hGetNonBlocking h k-        if S.null c-          then do eof <- hIsEOF h-                  if eof then hClose h >> return L.Empty-                         else hWaitForInput h (-1)-                            >> loop--          --then hClose h >> return Empty-          else do cs <- lazyRead-                  return (L.Chunk c cs)--hGetContents' :: Handle -> IO L.ByteString-hGetContents' = hGetContentsN L.defaultChunkSize--request :: Conf -> Handle -> Host -> (Request -> IO Response) -> IO ()-request conf h host handler = rloop conf h host handler =<< hGetContents' h--required :: String -> Maybe a -> Either String a-required err Nothing  = Left err-required _   (Just a) = Right a--transferEncodingC :: [Char]-transferEncodingC = "transfer-encoding"-rloop :: t-         -> Handle-         -> Host-         -> (Request -> IO Response)-         -> L.ByteString-         -> IO ()-rloop conf h host handler inputStr-    | L.null inputStr = return ()-    | otherwise-    = join $ withTimeOut (30 * second) $-      do let parseRequest-                 = do-                      (topStr, restStr) <- required "failed to separate request" $ splitAtEmptyLine inputStr-                      (rql, headerStr) <- required "failed to separate headers/body" $ splitAtCRLF topStr-                      let (m,u,v) = requestLine rql-                      headers' <- parseHeaders "host" (L.unpack headerStr)-                      let headers = mkHeaders headers'-                      let contentLength = fromMaybe 0 $ fmap fst (P.readInt =<< getHeaderUnsafe contentlengthC headers)-                      (body, nextRequest) <- case () of-                          () | contentLength < 0               -> fail "negative content-length"-                             | isJust $ getHeader transferEncodingC headers ->-                                 return $ consumeChunks restStr-                             | otherwise                       -> return (L.splitAt (fromIntegral contentLength) restStr)-                      let cookies = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" headers)), c <- cl ] -- Ugle-                          rqTmp = Request m (pathEls (path u)) (path u) (query u)-                                  [] cookies v headers (Body body) host-                          rq = rqTmp{rqInputs = queryInput u ++ bodyInput rqTmp}-                      return (rq, nextRequest)-         case parseRequest of-           Left err -> error $ "failed to parse HTTP request: " ++ err-           Right (req, rest)-               -> return $-                  do let ioseq act = act >>= \x -> x `seq` return x-                     res <- ioseq (handler req) `E.catch` \(e::E.SomeException) -> return $ result 500 $ "Server error: " ++ show e--                     -- combined log format-                     time <- getCurrentTime-                     let host' = fst host-                         user = "-"-                         requestLn = unwords [show $ rqMethod req, rqUri req, show $ rqVersion req]-                         responseCode = rsCode res-                         size = maybe (-1) (read . 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-                     logM "Happstack.Server.AccessLog.Combined" INFO $ formatRequestCombined host' user time requestLn responseCode size referer userAgent--                     putAugmentedResult h req res-                     when (continueHTTP req res) $ rloop conf h host handler rest---- | 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 True,rsValidator=Nothing}---- http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html--- note this does NOT handle extenions-consumeChunks::L.ByteString->(L.ByteString,L.ByteString)-consumeChunks str = let (parts,tr,rest) = consumeChunksImpl str in (L.concat . (++ [tr]) .map snd $ parts,rest)--consumeChunksImpl :: L.ByteString -> ([(Int64, L.ByteString)], L.ByteString, L.ByteString)-consumeChunksImpl str-    | L.null str = ([],L.empty,str)-    | chunkLen == 0 = let (last,rest') = L.splitAt lenLine1 str-                          (tr',rest'') = getTrailer rest'-                      in ([(0,last)],tr',rest'')-    | otherwise = ((chunkLen,part):crest,tr,rest2)-    where-      line1 = head $ lazylines str-      lenLine1 = (L.length line1) + 1 -- endchar-      chunkLen = (fst $ head $ readHex $ L.unpack line1)-      len = chunkLen + lenLine1 + 2-      (part,rest) = L.splitAt len str-      (crest,tr,rest2) = consumeChunksImpl rest-      getTrailer s = L.splitAt index s-          where index | crlfLC `L.isPrefixOf` s = 2-                      | otherwise = let iscrlf = L.zipWith (\a b -> a == '\r' && b == '\n') s . L.tail $ s-                                        Just i = elemIndex True $ zipWith (&&) iscrlf (tail (tail iscrlf))-                                    in fromIntegral $ i+4--crlfLC :: L.ByteString-crlfLC = L.pack "\r\n"---- Properly lazy version of 'lines' for lazy bytestrings-lazylines           :: L.ByteString -> [L.ByteString]-lazylines s-    | L.null s  = []-    | otherwise =-        let (l,s') = L.break ((==) '\n') s-        in l : if L.null s' then []-                            else lazylines (L.tail s')--requestLine :: L.ByteString -> (Method, SURI, Version)-requestLine l = case P.words ((P.concat . L.toChunks) l) of-                  [rq,uri,ver] -> (method rq, SURI $ parseURIRef uri, version ver)-                  [rq,uri] -> (method rq, SURI $ parseURIRef uri,Version 0 9)-                  x -> error $ "requestLine cannot handle input:  " ++ (show x)--responseLine :: L.ByteString -> (B.ByteString, Int)-responseLine l = case B.words ((B.concat . L.toChunks) l) of-                   (v:c:_) -> version v `seq` (v,fst (fromJust (B.readInt c)))-                   x -> error $ "responseLine cannot handle input: " ++ (show x)---method :: B.ByteString -> Method-method r = fj $ lookup r mtable-    where fj (Just x) = x-          fj Nothing  = error "invalid request method"-          mtable = [(P.pack "GET",     GET),-                    (P.pack "HEAD",    HEAD),-                    (P.pack "POST",    POST),-                    (P.pack "PUT",     PUT),-                    (P.pack "DELETE",  DELETE),-                    (P.pack "TRACE",   TRACE),-                    (P.pack "OPTIONS", OPTIONS),-                    (P.pack "CONNECT", CONNECT)]---- Result side--staticHeaders :: Headers-staticHeaders =-    foldr (uncurry setHeaderBS) (mkHeaders [])-    [ (serverC, happsC), (contentTypeC, textHtmlC) ]---- 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 :: Handle -> Request -> Response -> IO ()-putAugmentedResult outp req res = do-    case res of-        -- standard bytestring response-        Response {} -> do-            sendTop (fromIntegral (L.length (rsBody res)))-            when (rqMethod req /= HEAD) (L.hPut outp $ rsBody res)-        -- 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 count-            unsafeSendFile' outp infp off count-    hFlush outp-    where ph (HeaderPair k vs) = map (\v -> P.concat [k, fsepC, v, crlfC]) vs-          sendTop cl = do-              allHeaders <- augmentHeaders req res cl-              mapM_ (P.hPut outp) $ concat-                [ (pversion $ rqVersion req)          -- Print HTTP version-                , [responseMessage $ rsCode res]      -- Print responseCode-                , concatMap ph (M.elems allHeaders)   -- Print all headers-                , [crlfC]-                ]--augmentHeaders :: Request -> Response -> Integer -> IO Headers-augmentHeaders req res cl = 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])-                       ] ++ if rsfContentLength (rsFlags res)-                              then [(contentlengthC, HeaderPair contentLengthC [P.pack (show cl)])]-                              else [] )-    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]-      ]-    let Body body = rqBody rq-    L.hPut h  body-    hFlush h------ Version--pversion :: Version -> [B.ByteString]-pversion (Version 1 1) = [http11]-pversion (Version 1 0) = [http10]-pversion (Version x y) = [P.pack "HTTP/", P.pack (show x), P.pack ".", P.pack (show y)]--version :: B.ByteString -> Version-version x | x == http09 = Version 0 9-          | x == http10 = Version 1 0-          | x == http11 = Version 1 1-          | otherwise   = error "Invalid HTTP version"--http09 :: B.ByteString-http09 = P.pack "HTTP/0.9"-http10 :: B.ByteString-http10 = P.pack "HTTP/1.0"-http11 :: B.ByteString-http11 = P.pack "HTTP/1.1"---- Constants--connectionC :: B.ByteString-connectionC      = P.pack "Connection"-connectionCLower :: B.ByteString-connectionCLower = P.map toLower connectionC-closeC :: B.ByteString-closeC           = P.pack "close"-keepAliveC :: B.ByteString-keepAliveC       = P.pack "Keep-Alive"-crlfC :: B.ByteString-crlfC            = P.pack "\r\n"-fsepC :: B.ByteString-fsepC            = P.pack ": "-contentTypeC :: B.ByteString-contentTypeC     = P.pack "Content-Type"-contentLengthC :: B.ByteString-contentLengthC   = P.pack "Content-Length"-contentlengthC :: B.ByteString-contentlengthC   = P.pack "content-length"-dateC :: B.ByteString-dateC            = P.pack "Date"-dateCLower :: B.ByteString-dateCLower       = P.map toLower dateC-serverC :: B.ByteString-serverC          = P.pack "Server"-happsC :: B.ByteString-happsC           = P.pack $ "Happstack/" ++ DV.showVersion Paths.version-textHtmlC :: B.ByteString-textHtmlC        = P.pack "text/html; charset=utf-8"---- Response code names--responseMessage :: (Num t) => t -> B.ByteString-responseMessage 100 = P.pack " 100 Continue\r\n"-responseMessage 101 = P.pack " 101 Switching Protocols\r\n"-responseMessage 200 = P.pack " 200 OK\r\n"-responseMessage 201 = P.pack " 201 Created\r\n"-responseMessage 202 = P.pack " 202 Accepted\r\n"-responseMessage 203 = P.pack " 203 Non-Authoritative Information\r\n"-responseMessage 204 = P.pack " 204 No Content\r\n"-responseMessage 205 = P.pack " 205 Reset Content\r\n"-responseMessage 206 = P.pack " 206 Partial Content\r\n"-responseMessage 300 = P.pack " 300 Multiple Choices\r\n"-responseMessage 301 = P.pack " 301 Moved Permanently\r\n"-responseMessage 302 = P.pack " 302 Found\r\n"-responseMessage 303 = P.pack " 303 See Other\r\n"-responseMessage 304 = P.pack " 304 Not Modified\r\n"-responseMessage 305 = P.pack " 305 Use Proxy\r\n"-responseMessage 307 = P.pack " 307 Temporary Redirect\r\n"-responseMessage 400 = P.pack " 400 Bad Request\r\n"-responseMessage 401 = P.pack " 401 Unauthorized\r\n"-responseMessage 402 = P.pack " 402 Payment Required\r\n"-responseMessage 403 = P.pack " 403 Forbidden\r\n"-responseMessage 404 = P.pack " 404 Not Found\r\n"-responseMessage 405 = P.pack " 405 Method Not Allowed\r\n"-responseMessage 406 = P.pack " 406 Not Acceptable\r\n"-responseMessage 407 = P.pack " 407 Proxy Authentication Required\r\n"-responseMessage 408 = P.pack " 408 Request Time-out\r\n"-responseMessage 409 = P.pack " 409 Conflict\r\n"-responseMessage 410 = P.pack " 410 Gone\r\n"-responseMessage 411 = P.pack " 411 Length Required\r\n"-responseMessage 412 = P.pack " 412 Precondition Failed\r\n"-responseMessage 413 = P.pack " 413 Request Entity Too Large\r\n"-responseMessage 414 = P.pack " 414 Request-URI Too Large\r\n"-responseMessage 415 = P.pack " 415 Unsupported Media Type\r\n"-responseMessage 416 = P.pack " 416 Requested range not satisfiable\r\n"-responseMessage 417 = P.pack " 417 Expectation Failed\r\n"-responseMessage 500 = P.pack " 500 Internal Server Error\r\n"-responseMessage 501 = P.pack " 501 Not Implemented\r\n"-responseMessage 502 = P.pack " 502 Bad Gateway\r\n"-responseMessage 503 = P.pack " 503 Service Unavailable\r\n"-responseMessage 504 = P.pack " 504 Gateway Time-out\r\n"-responseMessage 505 = P.pack " 505 HTTP Version not supported\r\n"-responseMessage x   = P.pack (" " ++ show x ++ " \r\n")-

@@ -1,41 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-module Happstack.Server.HTTP.LazyLiner-    (Lazy, newLinerHandle, headerLines, getBytes, getBytesStrict, getRest, L.toChunks-    ) where--import Control.Concurrent.MVar-import System.IO-import qualified Data.ByteString.Char8 as P-import qualified Data.ByteString.Lazy.Char8 as L--newtype Lazy = Lazy (MVar L.ByteString)--newLinerHandle :: Handle -> IO Lazy-newLinerHandle h = fmap Lazy (newMVar =<< L.hGetContents h)--headerLines :: Lazy -> IO [P.ByteString]-headerLines (Lazy mv) = modifyMVar mv $ \l -> do-  let loop acc r0 = let (h,r) = L.break ((==) ch) r0-                        ph    = toStrict h-                        phl   = P.length ph-                        ph2   = if phl == 0 || P.last ph /= '\x0D' then ph else P.init ph-                        ch    = '\x0A'-                        r'    = if L.null r then r else L.tail r-                    in if P.length ph2 == 0 then (r', reverse acc) else loop (ph2:acc) r'-  return $ loop [] l--getBytesStrict :: Lazy -> Int -> IO P.ByteString-getBytesStrict (Lazy mv) len = modifyMVar mv $ \l -> do-  let (h,p) = L.splitAt (fromIntegral len) l-  return (p, toStrict h)--getBytes :: Lazy -> Int -> IO L.ByteString-getBytes (Lazy mv) len = modifyMVar mv $ \l -> do-  let (h,p) = L.splitAt (fromIntegral len) l-  return (p, h)--getRest :: Lazy -> IO L.ByteString-getRest (Lazy mv) = modifyMVar mv $ \l -> return (L.empty, l)--toStrict :: L.ByteString -> P.ByteString-toStrict = P.concat . L.toChunks

@@ -1,94 +0,0 @@-{-# LANGUAGE CPP, ScopedTypeVariables, ScopedTypeVariables #-}-module Happstack.Server.HTTP.Listen(listen, listen',listenOn) where--import Happstack.Server.HTTP.Types-import Happstack.Server.HTTP.Handler-import Happstack.Server.HTTP.Socket (acceptLite)-import Control.Exception.Extensible as E-import Control.Concurrent-import Network.BSD (getProtocolNumber)-import Network(sClose, Socket)-import Network.Socket as Socket (SocketOption(KeepAlive), setSocketOption, -                                 socket, Family(..), SockAddr, -                                 SocketOption(..), SockAddr(..), -                                 iNADDR_ANY, maxListenQueue, SocketType(..), -                                 bindSocket)-import qualified Network.Socket as Socket (listen)-import System.IO-{--#ifndef mingw32_HOST_OS--}-import System.Posix.Signals-{--#endif--}-import System.Log.Logger (Priority(..), logM)-log':: Priority -> String -> IO ()-log' = logM "Happstack.Server.HTTP.Listen"---{--   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)-        (sClose)-        (\sock -> do-            setSocketOption sock ReuseAddr 1-            bindSocket sock (SockAddrInet (fromIntegral portm) iNADDR_ANY)-            Socket.listen sock maxListenQueue-            return sock-        )----- | Bind and listen port-listen :: Conf -> (Request -> IO Response) -> IO ()-listen conf hand = do-    let port' = port conf-    socketm <- listenOn port'-    setSocketOption socketm KeepAlive 1-    listen' socketm conf hand---- | Use a previously bind port and listen-listen' :: Socket -> Conf -> (Request -> IO Response) -> IO ()-listen' s conf hand = do-{--#ifndef mingw32_HOST_OS--}-  installHandler openEndedPipe Ignore Nothing-{--#endif--}-  let port' = port conf-  log' NOTICE ("Listening on port " ++ show port')-  let work (h,hn,p) = do -- hSetBuffering h NoBuffering-                         let eh (x::SomeException) = log' ERROR ("HTTP request failed with: "++show x)-                         request conf h (hn,fromIntegral p) hand `E.catch` eh-                         hClose h-  let loop = do acceptLite s >>= forkIO . work-                loop-  let pe e = log' ERROR ("ERROR in accept thread: "++-                                                    show e)-  let infi = loop `catchSome` pe >> infi -- loop `E.catch` pe >> infi-  infi `finally` sClose s-{---#ifndef mingw32_HOST_OS--}-  installHandler openEndedPipe Ignore Nothing-  return ()-{--#endif--}-  where  -- why are these handlers needed?--    catchSome op h = op `E.catches` [-            Handler $ \(e :: ArithException) -> h (toException e),-            Handler $ \(e :: ArrayException) -> h (toException e)-          ]-

@@ -1,28 +0,0 @@-module Happstack.Server.HTTP.LowLevel-    (-- * HTTP Implementation-     -- $impl--     -- * Problems-     -- $problems--     -- * API-     module Happstack.Server.HTTP.Handler,-     module Happstack.Server.HTTP.Listen,-     module Happstack.Server.HTTP.Types-    ) where--import Happstack.Server.HTTP.Handler-import Happstack.Server.HTTP.Listen-import Happstack.Server.HTTP.Types---- $impl--- The Happstack HTTP implementation supports HTTP 1.0 and 1.1.--- Multiple request on a connection including pipelining is supported.---- $problems--- Currently if a client sends an invalid HTTP request the whole--- connection is aborted and no further processing is done.------ When the connection times out Happstack closes it. In future it could--- send a 408 response but this may be problematic if the sending--- of a response caused the problem.

@@ -1,215 +0,0 @@--- #hide---------------------------------------------------------------------------------- |--- Module      :  Happstack.Server.HTTP.Multipart--- Copyright   :  (c) Peter Thiemann 2001,2002---                (c) Bjorn Bringert 2005-2006---                (c) Lemmih 2007--- License     :  BSD-style------ Maintainer  :  lemmih@vo.com--- Stability   :  experimental--- Portability :  non-portable------ Parsing of the multipart format from RFC2046.--- Partly based on code from WASHMail.----------------------------------------------------------------------------------module Happstack.Server.HTTP.Multipart-    (-     -- * Multi-part messages-     MultiPart(..), BodyPart(..), Header-    , parseMultipartBody, hGetMultipartBody-     -- * Headers-    , ContentType(..), ContentTransferEncoding(..)-    , ContentDisposition(..)-    , parseContentType-    , parseContentTransferEncoding-    , parseContentDisposition-    , getContentType-    , getContentTransferEncoding-    , getContentDisposition--    , splitAtEmptyLine-    , splitAtCRLF-    , splitParts-    ) where--import Control.Monad-import Data.Int (Int64)-import Data.Maybe-import System.IO (Handle)--import Happstack.Server.HTTP.RFC822Headers--import qualified Data.ByteString.Lazy.Char8 as BS-import Data.ByteString.Lazy.Char8 (ByteString)------- * Multi-part stuff.-----data MultiPart = MultiPart [BodyPart]-               deriving (Show, Read, Eq, Ord)--data BodyPart = BodyPart [Header] ByteString-                deriving (Show, Read, Eq, Ord)---- | Read a multi-part message from a 'ByteString'.-parseMultipartBody :: String -- ^ Boundary-                   -> ByteString -> Maybe MultiPart-parseMultipartBody b s = -    do-    ps <- splitParts (BS.pack b) s-    liftM MultiPart $ mapM parseBodyPart ps---- | Read a multi-part message from a 'Handle'.---   Fails on parse errors.-hGetMultipartBody :: String -- ^ Boundary-                  -> Handle-                  -> IO MultiPart-hGetMultipartBody b h = -    do-    s <- BS.hGetContents h-    case parseMultipartBody b s of-        Nothing -> fail "Error parsing multi-part message"-        Just m  -> return m----parseBodyPart :: ByteString -> Maybe BodyPart-parseBodyPart s =-    do-    (hdr,bdy) <- splitAtEmptyLine s-    hs <- parseM pHeaders "<input>" (BS.unpack hdr)-    return $ BodyPart hs bdy------- * Splitting into multipart parts.------- | Split a multipart message into the multipart parts.-splitParts :: ByteString -- ^ The boundary, without the initial dashes-           -> ByteString -           -> Maybe [ByteString]-splitParts b s = dropPreamble b s >>= spl-  where-  spl x = case splitAtBoundary b x of-            Nothing -> Nothing-            Just (s1,d,s2) | isClose b d -> Just [s1]-                           | otherwise -> spl s2 >>= Just . (s1:)---- | Drop everything up to and including the first line starting ---   with the boundary. Returns 'Nothing' if there is no ---   line starting with a boundary.-dropPreamble :: ByteString -- ^ The boundary, without the initial dashes-             -> ByteString -             -> Maybe ByteString-dropPreamble b s | isBoundary b s = fmap snd (splitAtCRLF s)-                 | otherwise = dropLine s >>= dropPreamble b---- | Split a string at the first boundary line.-splitAtBoundary :: ByteString -- ^ The boundary, without the initial dashes-                -> ByteString -- ^ String to split.-                -> Maybe (ByteString,ByteString,ByteString)-                   -- ^ The part before the boundary, the boundary line,-                   --   and the part after the boundary line. The CRLF-                   --   before and the CRLF (if any) after the boundary line-                   --   are not included in any of the strings returned.-                   --   Returns 'Nothing' if there is no boundary.-splitAtBoundary b s = spl 0-  where-  spl i = case findCRLF (BS.drop i s) of-              Nothing -> Nothing-              Just (j,l) | isBoundary b s2 -> Just (s1,d,s3)-                         | otherwise -> spl (i+j+l)-                  where -                  s1 = BS.take (i+j) s-                  s2 = BS.drop (i+j+l) s-                  (d,s3) = splitAtCRLF_ s2---- | Check whether a string starts with two dashes followed by---   the given boundary string.-isBoundary :: ByteString -- ^ The boundary, without the initial dashes-           -> ByteString-           -> Bool-isBoundary b s = startsWithDashes s && b `BS.isPrefixOf` BS.drop 2 s---- | Check whether a string for which 'isBoundary' returns true---   has two dashes after the boudary string.-isClose :: ByteString -- ^ The boundary, without the initial dashes-        -> ByteString -        -> Bool-isClose b = startsWithDashes . BS.drop (2+BS.length b)---- | Checks whether a string starts with two dashes.-startsWithDashes :: ByteString -> Bool-startsWithDashes s = BS.pack "--" `BS.isPrefixOf` s-------- * RFC 2046 CRLF------- | Drop everything up to and including the first CRLF.-dropLine :: ByteString -> Maybe ByteString-dropLine = fmap snd . splitAtCRLF---- | Split a string at the first empty line. The CRLF (if any) before the---   empty line is included in the first result. The CRLF after the---   empty line is not included in the result.---   'Nothing' is returned if there is no empty line.-splitAtEmptyLine :: ByteString -> Maybe (ByteString, ByteString)-splitAtEmptyLine s | startsWithCRLF s = Just (BS.empty, dropCRLF s)-                   | otherwise = spl 0-  where-  spl i = case findCRLF (BS.drop i s) of-              Nothing -> Nothing-              Just (j,l) | startsWithCRLF s2 -> Just (s1, dropCRLF s2)-                         | otherwise -> spl (i+j+l)-                where (s1,s2) = BS.splitAt (i+j+l) s---- | Split a string at the first CRLF. The CRLF is not included---   in any of the returned strings.-splitAtCRLF :: ByteString -- ^ String to split.-            -> Maybe (ByteString,ByteString)-            -- ^  Returns 'Nothing' if there is no CRLF.-splitAtCRLF s = case findCRLF s of-                  Nothing -> Nothing-                  Just (i,l) -> Just (s1, BS.drop l s2)-                      where (s1,s2) = BS.splitAt i s---- | Like 'splitAtCRLF', but if no CRLF is found, the first---   result is the argument string, and the second result is empty.-splitAtCRLF_ :: ByteString -> (ByteString,ByteString)-splitAtCRLF_ s = fromMaybe (s,BS.empty) (splitAtCRLF s)---- | Get the index and length of the first CRLF, if any.-findCRLF :: ByteString -- ^ String to split.-         -> Maybe (Int64,Int64)-findCRLF s = -    case findCRorLF s of-              Nothing -> Nothing-              Just j | BS.null (BS.drop (j+1) s) -> Just (j,1)-              Just j -> case (BS.index s j, BS.index s (j+1)) of-                           ('\r','\n') -> Just (j,2)-                           _           -> Just (j,1)--findCRorLF :: ByteString -> Maybe Int64-findCRorLF = BS.findIndex (\c -> c == '\n' || c == '\r')--startsWithCRLF :: ByteString -> Bool-startsWithCRLF s = not (BS.null s) && (c == '\n' || c == '\r')-  where c = BS.index s 0---- | Drop an initial CRLF, if any. If the string is empty, ---   nothing is done. If the string does not start with CRLF,---   the first character is dropped.-dropCRLF :: ByteString -> ByteString-dropCRLF s | BS.null s = BS.empty-           | BS.null (BS.drop 1 s) = BS.empty-           | c0 == '\r' && c1 == '\n' = BS.drop 2 s-           | otherwise = BS.drop 1 s-  where c0 = BS.index s 0-        c1 = BS.index s 1

@@ -1,266 +0,0 @@--- #hide---------------------------------------------------------------------------------- |--- Module      :  Network.CGI.RFC822Headers--- Copyright   :  (c) Peter Thiemann 2001,2002---                (c) Bjorn Bringert 2005-2006---                (c) Lemmih 2007--- License     :  BSD-style------ Maintainer  :  lemmih@vo.com--- Stability   :  experimental--- Portability :  portable------ Parsing of RFC822-style headers (name, value pairs)--- Partly based on code from WASHMail.----------------------------------------------------------------------------------module Happstack.Server.HTTP.RFC822Headers-    ( -- * Headers-      Header, -      pHeader,-      pHeaders,-      parseHeaders,--      -- * Content-type-      ContentType(..), -      getContentType,-      parseContentType,-      showContentType,--      -- * Content-transfer-encoding-      ContentTransferEncoding(..),-      getContentTransferEncoding,-      parseContentTransferEncoding,--      -- * Content-disposition-      ContentDisposition(..),-      getContentDisposition,                           -      parseContentDisposition,-                              -      -- * Utilities-      parseM-      ) where--import Data.Char-import Data.List-import Text.ParserCombinators.Parsec--type Header = (String, String)--pHeaders :: Parser [Header]-pHeaders = many pHeader--parseHeaders :: Monad m => SourceName -> String -> m [Header]-parseHeaders = parseM pHeaders--pHeader :: Parser Header-pHeader = -    do name <- many1 headerNameChar-       char ':'-       many ws1-       line <- lineString-       crLf-       extraLines <- many extraFieldLine-       return (map toLower name, concat (line:extraLines))--extraFieldLine :: Parser String-extraFieldLine = -    do sp <- ws1-       line <- lineString-       crLf-       return (sp:line)------- * Parameters (for Content-type etc.)-----showParameters :: [(String,String)] -> String-showParameters = concatMap f-    where f (n,v) = "; " ++ n ++ "=\"" ++ concatMap esc v ++ "\""-          esc '\\' = "\\\\"-          esc '"'  = "\\\""-          esc c | c `elem` ['\\','"'] = '\\':[c]-                | otherwise = [c]--p_parameter :: Parser (String,String)-p_parameter =-  do lexeme $ char ';'-     p_name <- lexeme $ p_token-     lexeme $ char '='-     -- Workaround for seemingly standardized web browser bug-     -- where nothing is escaped in the filename parameter-     -- of the content-disposition header in multipart/form-data-     let litStr = if p_name == "filename" -                   then buggyLiteralString-                   else literalString-     p_value <- litStr <|> p_token-     return (map toLower p_name, p_value)----- --- * Content type------- | A MIME media type value.---   The 'Show' instance is derived automatically.---   Use 'showContentType' to obtain the standard---   string representation.---   See <http://www.ietf.org/rfc/rfc2046.txt> for more---   information about MIME media types.-data ContentType = -	ContentType {-                     -- | The top-level media type, the general type-                     --   of the data. Common examples are-                     --   \"text\", \"image\", \"audio\", \"video\",-                     --   \"multipart\", and \"application\".-                     ctType :: String,-                     -- | The media subtype, the specific data format.-                     --   Examples include \"plain\", \"html\",-                     --   \"jpeg\", \"form-data\", etc.-                     ctSubtype :: String,-                     -- | Media type parameters. On common example is-                     --   the charset parameter for the \"text\" -                     --   top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@.-                     ctParameters :: [(String, String)]-                    }-    deriving (Show, Read, Eq, Ord)---- | Produce the standard string representation of a content-type,---   e.g. \"text\/html; charset=ISO-8859-1\".-showContentType :: ContentType -> String-showContentType (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps--pContentType :: Parser ContentType-pContentType = -  do many ws1-     c_type <- p_token-     lexeme $ char '/'-     c_subtype <- lexeme $ p_token-     c_parameters <- many p_parameter-     return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters---- | Parse the standard representation of a content-type.---   If the input cannot be parsed, this function calls---   'fail' with a (hopefully) informative error message.-parseContentType :: Monad m => String -> m ContentType-parseContentType = parseM pContentType "Content-type"--getContentType :: Monad m => [Header] -> m ContentType-getContentType hs = lookupM "content-type" hs >>= parseContentType------- * Content transfer encoding-----data ContentTransferEncoding =-	ContentTransferEncoding String-    deriving (Show, Read, Eq, Ord)--pContentTransferEncoding :: Parser ContentTransferEncoding-pContentTransferEncoding =-  do many ws1-     c_cte <- p_token-     return $ ContentTransferEncoding (map toLower c_cte)--parseContentTransferEncoding :: Monad m => String -> m ContentTransferEncoding-parseContentTransferEncoding = -    parseM pContentTransferEncoding "Content-transfer-encoding"--getContentTransferEncoding :: Monad m => [Header] -> m ContentTransferEncoding-getContentTransferEncoding hs = -    lookupM "content-transfer-encoding" hs >>= parseContentTransferEncoding------- * Content disposition-----data ContentDisposition =-	ContentDisposition String [(String, String)]-    deriving (Show, Read, Eq, Ord)--pContentDisposition :: Parser ContentDisposition-pContentDisposition =-  do many ws1-     c_cd <- p_token-     c_parameters <- many p_parameter-     return $ ContentDisposition (map toLower c_cd) c_parameters--parseContentDisposition :: Monad m => String -> m ContentDisposition-parseContentDisposition = parseM pContentDisposition "Content-disposition"--getContentDisposition :: Monad m => [Header] -> m ContentDisposition-getContentDisposition hs = -    lookupM "content-disposition" hs  >>= parseContentDisposition------- * Utilities-----parseM :: Monad m => Parser a -> SourceName -> String -> m a-parseM p n inp =-  case parse p n inp of-    Left e -> fail (show e)-    Right x -> return x--lookupM :: (Monad m, Eq a, Show a) => a -> [(a,b)] -> m b-lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n---- --- * Parsing utilities------- | RFC 822 LWSP-char-ws1 :: Parser Char-ws1 = oneOf " \t"--lexeme :: Parser a -> Parser a-lexeme p = do x <- p; many ws1; return x---- | RFC 822 CRLF (but more permissive)-crLf :: Parser String-crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r"---- | One line-lineString :: Parser String-lineString = many (noneOf "\n\r")--literalString :: Parser String-literalString = do char '\"'-		   str <- many (noneOf "\"\\" <|> quoted_pair)-		   char '\"'-		   return str---- No web browsers seem to implement RFC 2046 correctly,--- since they do not escape double quotes and backslashes--- in the filename parameter in multipart/form-data.------ Note that this eats everything until the last double quote on the line.-buggyLiteralString :: Parser String-buggyLiteralString = -    do char '\"'-       str <- manyTill anyChar (try lastQuote)-       return str-  where lastQuote = do char '\"' -                       notFollowedBy (try (many (noneOf "\"") >> char '\"'))--headerNameChar :: Parser Char-headerNameChar = noneOf "\n\r:"--especials, tokenchar :: [Char]-especials = "()<>@,;:\\\"/[]?.="-tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials--p_token :: Parser String-p_token = many1 (oneOf tokenchar)--text_chars :: [Char]-text_chars = map chr ([1..9] ++ [11,12] ++ [14..127])--p_text :: Parser Char-p_text = oneOf text_chars--quoted_pair :: Parser Char-quoted_pair = do char '\\'-		 p_text

@@ -1,52 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Happstack.Server.HTTP.Socket(acceptLite) where--import Happstack.Server.HTTP.SocketTH(supportsIPv6)-import Language.Haskell.TH.Syntax-import Happstack.Util.HostAddress-import qualified Network as N-  ( PortID(PortNumber)-  , socketPort-  )-import qualified Network.Socket as S-  ( Socket(..)-  , PortNumber()-  , SockAddr(..)-  , HostName-  , accept-  , socketToHandle-  )-import System.IO---- | alternative implementation of accept to work around EAI_AGAIN errors-acceptLite :: S.Socket -> IO (Handle, S.HostName, S.PortNumber)-acceptLite sock = do-  (sock', addr) <- S.accept sock-  h <- S.socketToHandle sock' ReadWriteMode-  (N.PortNumber p) <- N.socketPort sock'-  -  let peer = $(if supportsIPv6-                 then-                 return $ CaseE (VarE (mkName "addr")) -                            [Match -                             (ConP (mkName "S.SockAddrInet") -                              [WildP,VarP (mkName "ha")]) -                             (NormalB (AppE (VarE (mkName "showHostAddress")) -                                       (VarE (mkName "ha")))) []-                            ,Match (ConP (mkName "S.SockAddrInet6") [WildP,WildP,VarP (mkName "ha"),WildP])-                             (NormalB (AppE (VarE (mkName "showHostAddress6")) (VarE (mkName "ha")))) []-                            ,Match WildP (NormalB (AppE (VarE (mkName "error")) (LitE (StringL "Unsupported socket")))) []]-                 -- the above mess is the equivalent of this: -                 {-[| case addr of-                       (S.SockAddrInet _ ha)      -> showHostAddress ha-                       (S.SockAddrInet6 _ _ ha _) -> showHostAddress6 ha-                       _                          -> error "Unsupported socket"-                   |]-}-                 else-                 [| case addr of-                      (S.SockAddrInet _ ha)      -> showHostAddress ha-                      _                          -> error "Unsupported socket"-                 |])-                     -  return (h, peer, p)-

@@ -1,15 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Happstack.Server.HTTP.SocketTH(supportsIPv6) where-import Language.Haskell.TH--import Data.List-import Data.Maybe-import Network.Socket(SockAddr(..))---- find out at compile time if the SockAddr6 / HostAddress6 constructors are available-supportsIPv6 :: Bool-supportsIPv6 = $(let c = ["Network.Socket.SockAddrInet6", "Network.Socket.Internal.SockAddrInet6"] ; d = ''SockAddr in-                 do TyConI (DataD _ _ _ cs _) <- reify d-                    if isJust (find (\(NormalC n _) -> show n `elem` c) cs)-                       then [| True |]-                       else [| False |] )

@@ -1,260 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}--module Happstack.Server.HTTP.Types-    (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..),-     rqURL, mkHeaders,-     getHeader, getHeaderBS, getHeaderUnsafe,-     hasHeader, hasHeaderBS, hasHeaderUnsafe,-     setHeader, setHeaderBS, setHeaderUnsafe,-     addHeader, addHeaderBS, addHeaderUnsafe,-     setRsCode, -- setCookie, setCookies,-     Conf(..), nullConf, result, resultBS,-     redirect, -- redirect_, redirect', redirect'_,-     RsFlags(..), nullRsFlags, noContentLength,-     Version(..), Method(..), Headers, continueHTTP,-     Host, ContentType(..)-    ) where---import qualified Data.Map as M-import Data.Typeable(Typeable)-import Data.Maybe-import qualified Data.ByteString.Char8 as P-import Data.ByteString.Char8 (ByteString,pack)-import qualified Data.ByteString.Lazy.Char8 as L-import Happstack.Server.SURI-import Data.Char (toLower)--import Happstack.Server.HTTP.Multipart ( ContentType(..) )-import Happstack.Server.Cookie-import Data.List-import Text.Show.Functions ()---- | HTTP version-data Version = Version Int Int-             deriving(Read,Eq)--instance Show Version where-  show (Version x y) = (show x) ++ "." ++ (show y)--isHTTP1_1 :: Request -> Bool-isHTTP1_1 rq = case rqVersion rq of Version 1 1 -> True; _ -> False-isHTTP1_0 :: Request -> Bool-isHTTP1_0 rq = case rqVersion rq of Version 1 0 -> True; _ -> False---- | Should the connection be used for further messages after this.--- | isHTTP1_0 && hasKeepAlive || isHTTP1_1 && hasNotConnectionClose-continueHTTP :: Request -> Response -> Bool---continueHTTP rq res = isHTTP1_1 rq && getHeader' connectionC rq /= Just closeC && rsfContentLength (rsFlags res)-continueHTTP rq res = (isHTTP1_0 rq && checkHeaderBS connectionC keepaliveC rq) ||-                      (isHTTP1_1 rq && not (checkHeaderBS connectionC closeC rq)) && rsfContentLength (rsFlags res)---- | HTTP configuration-data Conf = Conf { port      :: Int -- ^ Port for the server to listen on.-                 , validator  :: Maybe (Response -> IO Response)-                 } ---- | Default configuration contains no validator and the port is set to 8000-nullConf :: Conf-nullConf = Conf { port      = 8000-                , validator  = Nothing-                }---- | HTTP request method-data Method  = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT-               deriving(Show,Read,Eq)--data HeaderPair = HeaderPair { hName :: ByteString, hValue :: [ByteString] } deriving (Read,Show)--- | Combined headers.-type Headers = M.Map ByteString HeaderPair -- lowercased name -> (realname, value)------ | Result flags-data RsFlags = RsFlags -    { rsfContentLength :: Bool -- ^ whether a content-length header will be added to the result.-    } deriving(Show,Read,Typeable)---- | Default RsFlags that will include the content-length header-nullRsFlags :: RsFlags-nullRsFlags = RsFlags { rsfContentLength = True }--- | Don't display a Content-Lenght field for the 'Result'.-noContentLength :: Response -> Response-noContentLength res = res { rsFlags = upd } where upd = (rsFlags res) { rsfContentLength = False }--data Input = Input-    { inputValue :: L.ByteString-    , inputFilename :: Maybe String-    , inputContentType :: ContentType-    } deriving (Show,Read,Typeable)--type Host = (String,Int)--data Response  = Response  { rsCode      :: Int,-                             rsHeaders   :: Headers,-                             rsFlags     :: RsFlags,-                             rsBody      :: L.ByteString,-                             rsValidator :: Maybe (Response -> IO Response)-                           }-               | 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 (Show,Typeable) --data Request = Request { rqMethod  :: Method,-                         rqPaths   :: [String],-			 rqUri	   :: String,-                         rqQuery   :: String,-                         rqInputs  :: [(String,Input)],-                         rqCookies :: [(String,Cookie)],-                         rqVersion :: Version,-                         rqHeaders :: Headers,-                         rqBody    :: RqBody,-                         rqPeer    :: Host-                       } deriving(Show,Read,Typeable)---- | Converts a Request into a String representing the corresponding URL-rqURL :: Request -> String-rqURL rq = '/':intercalate "/" (rqPaths rq) ++ (rqQuery rq)--class HasHeaders a where -    updateHeaders::(Headers->Headers)->a->a-    headers::a->Headers--instance HasHeaders Response where updateHeaders f rs = rs{rsHeaders=f $ rsHeaders rs}-                                   headers = rsHeaders-instance HasHeaders Request where updateHeaders f rq = rq{rqHeaders = f $ rqHeaders rq} -                                  headers = rqHeaders--instance HasHeaders Headers where updateHeaders f = f-                                  headers = id--newtype RqBody = Body L.ByteString deriving (Read,Show,Typeable)---- | Sets the Response status code to the provided Int and lifts the computation--- into a Monad.-setRsCode :: (Monad m) => Int -> Response -> m Response-setRsCode code rs = return rs {rsCode = code}---- | Takes a list of (key,val) pairs and converts it into Headers.  The--- keys will be converted to lowercase-mkHeaders :: [(String,String)] -> Headers-mkHeaders hdrs-    = M.fromListWith join [ (P.pack (map toLower key), HeaderPair (P.pack key) [P.pack value]) | (key,value) <- hdrs ]-    where join (HeaderPair key vs1) (HeaderPair _ vs2) = HeaderPair key (vs1++vs2)------------------------------------------------------------------- Retrieving header information------------------------------------------------------------------- | Lookup header value. Key is case-insensitive.-getHeader :: HasHeaders r => String -> r -> Maybe ByteString-getHeader = getHeaderBS . pack---- | Lookup header value. Key is a case-insensitive bytestring.-getHeaderBS :: HasHeaders r => ByteString -> r -> Maybe ByteString-getHeaderBS = getHeaderUnsafe . P.map toLower---- | Lookup header value with a case-sensitive key. The key must be lowercase.-getHeaderUnsafe :: HasHeaders r => ByteString -> r -> Maybe ByteString-getHeaderUnsafe key var = listToMaybe =<< fmap hValue (getHeaderUnsafe' key var)---- | Lookup header with a case-sensitive key. The key must be lowercase.-getHeaderUnsafe' :: HasHeaders r => ByteString -> r -> Maybe HeaderPair-getHeaderUnsafe' key = M.lookup key . headers------------------------------------------------------------------- Querying header status------------------------------------------------------------------- | Returns True if the associated key is found in the Headers.  The lookup--- is case insensitive.-hasHeader :: HasHeaders r => String -> r -> Bool-hasHeader key r = isJust (getHeader key r)---- | Acts as 'hasHeader' with ByteStrings-hasHeaderBS :: HasHeaders r => ByteString -> r -> Bool-hasHeaderBS key r = isJust (getHeaderBS key r)---- | Acts as 'hasHeaderBS' but the key is case sensitive.  It should be--- in lowercase.-hasHeaderUnsafe :: HasHeaders r => ByteString -> r -> Bool-hasHeaderUnsafe key r = isJust (getHeaderUnsafe' key r)--checkHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> Bool-checkHeaderBS key val = checkHeaderUnsafe (P.map toLower key) (P.map toLower val)--checkHeaderUnsafe :: HasHeaders r => ByteString -> ByteString -> r -> Bool-checkHeaderUnsafe key val r-    = case getHeaderUnsafe key r of-        Just val' | P.map toLower val' == val -> True-        _ -> False-------------------------------------------------------------------- Setting header status------------------------------------------------------------------- | Associates the key/value pair in the headers.  Forces the key to be--- lowercase.-setHeader :: HasHeaders r => String -> String -> r -> r-setHeader key val = setHeaderBS (pack key) (pack val)---- | Acts as 'setHeader' but with ByteStrings.-setHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r-setHeaderBS key val = setHeaderUnsafe (P.map toLower key) (HeaderPair key [val])---- | Sets the key to the HeaderPair.  This is the only way to associate a key--- with multiple values via the setHeader* functions.  Does not force the key--- to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. -setHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r-setHeaderUnsafe key val = updateHeaders (M.insert key val)------------------------------------------------------------------- Adding headers------------------------------------------------------------------- | Add a key/value pair to the header.  If the key already has a value--- associated with it, then the value will be appended.  --- Forces the key to be lowercase.-addHeader :: HasHeaders r => String -> String -> r -> r-addHeader key val = addHeaderBS (pack key) (pack val)---- | Acts as addHeader except for ByteStrings-addHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r-addHeaderBS key val = addHeaderUnsafe (P.map toLower key) (HeaderPair key [val])---- | Add a key/value pair to the header using the underlying HeaderPair data--- type.  Does not force the key to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. -addHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r-addHeaderUnsafe key val = updateHeaders (M.insertWith join key val)-    where join (HeaderPair k vs1) (HeaderPair _ vs2) = HeaderPair k (vs1++vs2)---- | Creates a Response with the given Int as the status code and the provided--- String as the body of the Response -result :: Int -> String -> Response-result code = resultBS code . L.pack---- | Acts as 'result' but works with ByteStrings directly.-resultBS :: Int -> L.ByteString -> Response-resultBS code s = Response code M.empty nullRsFlags s Nothing---- | Sets the Response's status code to the given Int and redirects to the given URI-redirect :: (ToSURI s) => Int -> s -> Response -> Response-redirect c s resp = setHeaderBS locationC (pack (render (toSURI s))) resp{rsCode = c}---- constants here-locationC :: ByteString-locationC   = P.pack "Location"-closeC :: ByteString-closeC      = P.pack "close"-connectionC :: ByteString-connectionC = P.pack "Connection"-keepaliveC :: ByteString-keepaliveC  = P.pack "Keep-Alive"-

@@ -0,0 +1,59 @@+{-# OPTIONS -fno-cse #-}+module Happstack.Server.Internal.Clock+    ( getApproximateTime+    , getApproximatePOSIXTime+    , getApproximateUTCTime+    , formatHttpDate+    ) where++import Control.Applicative   ((<$>))+import Control.Concurrent+import Data.IORef+import Data.Time.Clock       (UTCTime)+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)+import Data.Time.Format      (formatTime)+import System.IO.Unsafe+import System.Locale++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)+  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

@@ -0,0 +1,204 @@+{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}+-- | Filter for compressing the 'Response' body.+module Happstack.Server.Internal.Compression+    ( compressedResponseFilter+    , compressWithFilter+    , gzipFilter+    , deflateFilter+    , encodings+    ) where+import Happstack.Server.SimpleHTTP+import Text.ParserCombinators.Parsec+import Control.Monad+import Data.Maybe+import Data.List+import qualified Data.ByteString.Char8 as BS+import qualified 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@.+--+-- > main = +-- >   simpleHTTP nullConf $ +-- >      do str <- compressedResponseFilter+-- >         return $ toResponse ("This response compressed using: " ++ str)+compressedResponseFilter::+    (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m)+    => m String -- ^ name of the encoding chosen+compressedResponseFilter = do+    getHeaderM "Accept-Encoding" >>=+        (maybe (return "identity") installHandler)++  where+    badEncoding = "Encoding returned not in the list of known encodings"++    installHandler accept = do+      let eEncoding = bestEncoding allEncodings $ 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 allEncodingHandlers)+                                     )+      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++-- | 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' and 'defaultFilter'+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 $ 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)+++allEncodingHandlers:: (FilterMonad Response m) => [(String, String -> Bool -> m ())]+allEncodingHandlers = zip allEncodings handlers++allEncodings :: [String]+allEncodings =+    ["gzip"+    ,"x-gzip"+--    ,"compress" -- as far as I can tell there is no haskell library that supports this+--    ,"x-compress" -- as far as I can tell, there is no haskell library that supports this+    ,"deflate"+    ,"identity"+    ,"*"+    ]++handlers::(FilterMonad Response m) => [String -> Bool -> m ()]+handlers =+    [gzipFilter+    ,gzipFilter+--    ,compressFilter+--    ,compressFilter+    ,deflateFilter+    , \encoding _ -> setHeaderM "Accept-Encoding" encoding+    ,const $ fail "chose * as content encoding"+    ]++-- | a parser for the Accept-Encoding header+encodings :: GenParser Char st [([Char], Maybe Double)]+encodings = ws >> (encoding1 `sepBy` try sep) >>= (\x -> ws >> eof >> return x)+    where+        ws :: 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

@@ -0,0 +1,187 @@+{-# 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.Applicative   ((<$>))+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 Data.Time.Format      (formatTime)+import Happstack.Util.Common (Seconds)+import Happstack.Server.Internal.Clock (getApproximateUTCTime)+import Text.ParserCombinators.Parsec hiding (token)+import System.Locale         (defaultTimeLocale)++-- | a type for HTTP cookies. Usually created using 'mkCookie'.+data Cookie = Cookie+    { cookieVersion :: String+    , cookiePath    :: String+    , cookieDomain  :: String+    , cookieName    :: String+    , cookieValue   :: String+    , secure        :: 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 Seconds  -- ^ 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 (Seconds, 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 "/", and secure == False+--+-- see also: 'addCookie'+mkCookie :: String  -- ^ cookie name+         -> String  -- ^ cookie value+         -> Cookie+mkCookie key val = Cookie "1" "/" "" key val 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 (Seconds, 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 [])++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+          cookie_version = cookie_special "$Version"+          cookie_path = cookie_special "$Path"+          cookie_domain = cookie_special "$Domain"+          cookie_special s = do+            string s+            cookieEq+            value+          cookieSep = ws >> oneOf ",;" >> ws+          cookieEq = ws >> char '=' >> ws+          ws = spaces+          value         = word+          word          = try (quoted_string) <|> incomp_token++          -- Parsers based on RFC 2068+          quoted_string = do+            char '"'+            r <-many (oneOf qdtext)+            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 \\ "\""++-- | 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+

@@ -0,0 +1,388 @@+{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables #-}++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 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.Internal.NoPush+import Happstack.Server.SURI(SURI(..),path,query)+import Happstack.Server.SURI.ParseURI+import qualified Happstack.Server.Internal.TimeoutManager as TM+import Happstack.Server.Internal.TimeoutSocket (sGetContents, sPutTickle, sendFileTickle)+import Network.Socket (Socket)+import Network.Socket.ByteString (sendAll)+import Numeric+import System.Directory (removeFile)+import System.IO+import System.IO.Error (isDoesNotExistError)++request :: TM.Handle -> Conf -> Socket -> Host -> (Request -> IO Response) -> IO ()+request thandle conf sock host handler = rloop thandle conf sock host handler =<< sGetContents thandle sock++required :: String -> Maybe a -> Either String a+required err Nothing  = Left err+required _   (Just a) = Right a++rloop :: TM.Handle+         -> Conf+         -> Socket+         -> Host+         -> (Request -> IO Response)+         -> L.ByteString+         -> IO ()+rloop thandle conf sock 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 contentLength = fromMaybe 0 $ fmap fst (P.readInt =<< getHeaderUnsafe contentlengthC headers)+                      (body, nextRequest) <- case () of+                          () | contentLength < 0               -> fail "negative content-length"+                             | isJust $ getHeaderBS transferEncodingC headers ->+                                 return $ consumeChunks restStr+                             | otherwise                       -> return (L.splitAt (fromIntegral contentLength) restStr)+                      let cookies = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" headers)), c <- cl ] -- Ugle+                      return (m, u, cookies, v, headers, body, host, nextRequest)++         case parseRequest of+           Left err -> error $ "failed to parse HTTP request: " ++ err+           Right (m, u, cookies, v, headers, body, host, nextRequest)+               -> return $+                  do bodyRef        <- newMVar (Body body)+                     bodyInputRef   <- newEmptyMVar+                     let req = Request 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 <- ioseq (handler req) `E.catch` \(e::E.SomeException) -> return $ result 500 $ "Server error: " ++ show e++                     case logAccess conf 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) (read . 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 thandle sock req res+                     -- clean up tmp files+                     cleanupTempFiles req+                     when (continueHTTP req res) $ rloop thandle conf sock 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  = error "invalid request method"+          mtable = [(P.pack "GET",     GET),+                    (P.pack "HEAD",    HEAD),+                    (P.pack "POST",    POST),+                    (P.pack "PUT",     PUT),+                    (P.pack "DELETE",  DELETE),+                    (P.pack "TRACE",   TRACE),+                    (P.pack "OPTIONS", OPTIONS),+                    (P.pack "CONNECT", CONNECT)]++-- Result side++staticHeaders :: Headers+staticHeaders =+    foldr (uncurry setHeaderBS) (mkHeaders [])+    [ (serverC, happsC) ]++-- FIXME: we should not be controlling the response headers in mysterious ways in this low level code+-- headers should be set by application code and the core http engine should be very lean.+putAugmentedResult :: TM.Handle -> Socket -> Request -> Response -> IO ()+putAugmentedResult thandle outp req res = do+    case res of+        -- standard bytestring response+        Response {} -> do+            let chunked = rsfLength (rsFlags res) == TransferEncodingChunked && isHTTP1_1 req+            sendTop (if chunked then Nothing else (Just (fromIntegral (L.length (rsBody res))))) chunked+            when (rqMethod req /= HEAD)+                     (let body = if chunked+                                 then chunk (rsBody res)+                                 else rsBody res+                      in sPutTickle thandle outp 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 thandle+            sendFileTickle thandle outp infp off count++    where ph (HeaderPair k vs) = map (\v -> P.concat [k, fsepC, v, crlfC]) vs+          sendTop cl chunked = do+              allHeaders <- augmentHeaders req res cl chunked+              sendAll outp $ B.concat $ concat+                 [ (pversion $ rqVersion req)          -- Print HTTP version+                 , [responseMessage $ rsCode res]      -- Print responseCode+                 , concatMap ph (M.elems allHeaders)   -- Print all headers+                 , [crlfC]+                 ]+              TM.tickle thandle+          chunk :: L.ByteString -> L.ByteString+          chunk Empty        = LC.pack "0\r\n\r\n"+          chunk (Chunk c cs) = Chunk (B.pack $ showHex (B.length c) "\r\n") (Chunk c (Chunk (B.pack "\r\n") (chunk cs)))++augmentHeaders :: Request -> Response -> Maybe Integer -> Bool -> IO Headers+augmentHeaders req res mcl chunked = do+    -- 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+                                  | chunked   -> [(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"++-- Constants++connectionC :: B.ByteString+connectionC      = P.pack "Connection"+connectionCLower :: B.ByteString+connectionCLower = P.map toLower connectionC+closeC :: B.ByteString+closeC           = P.pack "close"+keepAliveC :: B.ByteString+keepAliveC       = P.pack "Keep-Alive"+crlfC :: B.ByteString+crlfC            = P.pack "\r\n"+fsepC :: B.ByteString+fsepC            = P.pack ": "+contentTypeC :: B.ByteString+contentTypeC     = P.pack "Content-Type"+contentLengthC :: B.ByteString+contentLengthC   = P.pack "Content-Length"+contentlengthC :: B.ByteString+contentlengthC   = P.pack "content-length"+dateC :: B.ByteString+dateC            = P.pack "Date"+dateCLower :: B.ByteString+dateCLower       = P.map toLower dateC+serverC :: B.ByteString+serverC          = P.pack "Server"+happsC :: B.ByteString+happsC           = P.pack $ "Happstack/" ++ DV.showVersion Paths.version+textHtmlC :: B.ByteString+textHtmlC        = P.pack "text/html; charset=utf-8"+transferEncodingC :: B.ByteString+transferEncodingC = P.pack "Transfer-Encoding"+chunkedC :: B.ByteString+chunkedC = P.pack "chunked"++-- Response code names++responseMessage :: (Num t) => t -> B.ByteString+responseMessage 100 = P.pack " 100 Continue\r\n"+responseMessage 101 = P.pack " 101 Switching Protocols\r\n"+responseMessage 200 = P.pack " 200 OK\r\n"+responseMessage 201 = P.pack " 201 Created\r\n"+responseMessage 202 = P.pack " 202 Accepted\r\n"+responseMessage 203 = P.pack " 203 Non-Authoritative Information\r\n"+responseMessage 204 = P.pack " 204 No Content\r\n"+responseMessage 205 = P.pack " 205 Reset Content\r\n"+responseMessage 206 = P.pack " 206 Partial Content\r\n"+responseMessage 300 = P.pack " 300 Multiple Choices\r\n"+responseMessage 301 = P.pack " 301 Moved Permanently\r\n"+responseMessage 302 = P.pack " 302 Found\r\n"+responseMessage 303 = P.pack " 303 See Other\r\n"+responseMessage 304 = P.pack " 304 Not Modified\r\n"+responseMessage 305 = P.pack " 305 Use Proxy\r\n"+responseMessage 307 = P.pack " 307 Temporary Redirect\r\n"+responseMessage 400 = P.pack " 400 Bad Request\r\n"+responseMessage 401 = P.pack " 401 Unauthorized\r\n"+responseMessage 402 = P.pack " 402 Payment Required\r\n"+responseMessage 403 = P.pack " 403 Forbidden\r\n"+responseMessage 404 = P.pack " 404 Not Found\r\n"+responseMessage 405 = P.pack " 405 Method Not Allowed\r\n"+responseMessage 406 = P.pack " 406 Not Acceptable\r\n"+responseMessage 407 = P.pack " 407 Proxy Authentication Required\r\n"+responseMessage 408 = P.pack " 408 Request Time-out\r\n"+responseMessage 409 = P.pack " 409 Conflict\r\n"+responseMessage 410 = P.pack " 410 Gone\r\n"+responseMessage 411 = P.pack " 411 Length Required\r\n"+responseMessage 412 = P.pack " 412 Precondition Failed\r\n"+responseMessage 413 = P.pack " 413 Request Entity Too Large\r\n"+responseMessage 414 = P.pack " 414 Request-URI Too Large\r\n"+responseMessage 415 = P.pack " 415 Unsupported Media Type\r\n"+responseMessage 416 = P.pack " 416 Requested range not satisfiable\r\n"+responseMessage 417 = P.pack " 417 Expectation Failed\r\n"+responseMessage 500 = P.pack " 500 Internal Server Error\r\n"+responseMessage 501 = P.pack " 501 Not Implemented\r\n"+responseMessage 502 = P.pack " 502 Bad Gateway\r\n"+responseMessage 503 = P.pack " 503 Service Unavailable\r\n"+responseMessage 504 = P.pack " 504 Gateway Time-out\r\n"+responseMessage 505 = P.pack " 505 HTTP Version not supported\r\n"+responseMessage x   = P.pack (" " ++ show x ++ " \r\n")

@@ -0,0 +1,41 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Happstack.Server.Internal.LazyLiner+    (Lazy, newLinerHandle, headerLines, getBytes, getBytesStrict, getRest, L.toChunks+    ) where++import Control.Concurrent.MVar+import System.IO+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Lazy.Char8 as L++newtype Lazy = Lazy (MVar L.ByteString)++newLinerHandle :: Handle -> IO Lazy+newLinerHandle h = fmap Lazy (newMVar =<< L.hGetContents h)++headerLines :: Lazy -> IO [P.ByteString]+headerLines (Lazy mv) = modifyMVar mv $ \l -> do+  let loop acc r0 = let (h,r) = L.break ((==) ch) r0+                        ph    = toStrict h+                        phl   = P.length ph+                        ph2   = if phl == 0 || P.last ph /= '\x0D' then ph else P.init ph+                        ch    = '\x0A'+                        r'    = if L.null r then r else L.tail r+                    in if P.length ph2 == 0 then (r', reverse acc) else loop (ph2:acc) r'+  return $ loop [] l++getBytesStrict :: Lazy -> Int -> IO P.ByteString+getBytesStrict (Lazy mv) len = modifyMVar mv $ \l -> do+  let (h,p) = L.splitAt (fromIntegral len) l+  return (p, toStrict h)++getBytes :: Lazy -> Int -> IO L.ByteString+getBytes (Lazy mv) len = modifyMVar mv $ \l -> do+  let (h,p) = L.splitAt (fromIntegral len) l+  return (p, h)++getRest :: Lazy -> IO L.ByteString+getRest (Lazy mv) = modifyMVar mv $ \l -> return (L.empty, l)++toStrict :: L.ByteString -> P.ByteString+toStrict = P.concat . L.toChunks

@@ -0,0 +1,103 @@+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}+module Happstack.Server.Internal.Listen(listen, listen',listenOn) 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)+import Control.Exception.Extensible             as E+import Control.Concurrent                       (forkIO, killThread, myThreadId)+import Control.Monad                            (forever, when)+import Network.BSD                              (getProtocolNumber)+import Network                                  (sClose, Socket)+import Network.Socket as Socket (SocketOption(KeepAlive), setSocketOption, +                                 socket, Family(..), SockAddr, +                                 SocketOption(..), SockAddr(..), +                                 iNADDR_ANY, maxListenQueue, SocketType(..), +                                 bindSocket)+import qualified Network.Socket                 as Socket (listen)+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)+        (sClose)+        (\sock -> do+            setSocketOption sock ReuseAddr 1+            bindSocket sock (SockAddrInet (fromIntegral portm) iNADDR_ANY)+            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+    socketm <- listenOn port'+    setSocketOption socketm KeepAlive 1+    listen' socketm 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+-}+  installHandler openEndedPipe Ignore Nothing+{-+#endif+-}+  let port' = port conf+  log' NOTICE ("Listening on port " ++ show port')+  tm <- initialize ((timeout conf) * (10^(6 :: Int)))+  let eh (x::SomeException) = when ((fromException x) /= Just ThreadKilled) $ log' ERROR ("HTTP request failed with: " ++ show x)+      work (sock, hn, p) = +          do tid <- myThreadId+             thandle <- register tm (killThread tid)+             request thandle conf sock (hn,fromIntegral p) hand `E.catch` eh+             -- remove thread from timeout table+             cancel thandle+             sClose sock+      loop = forever $ do w <- acceptLite s+                          forkIO $ work w+      pe e = log' ERROR ("ERROR in accept thread: " ++ show e)+      infi = loop `catchSome` pe >> infi+  infi `finally` (sClose s) --  >> killThread ttid)+{--+#ifndef mingw32_HOST_OS+-}+  installHandler openEndedPipe Ignore Nothing+  return ()+{-+#endif+-}+  where  -- why are these handlers needed?++    catchSome op h = op `E.catches` [+            Handler $ \(e :: ArithException) -> h (toException e),+            Handler $ \(e :: ArrayException) -> h (toException e),+            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+          ]

@@ -0,0 +1,28 @@+module Happstack.Server.Internal.LowLevel+    (-- * HTTP Implementation+     -- $impl++     -- * Problems+     -- $problems++     -- * API+     module Happstack.Server.Internal.Handler,+     module Happstack.Server.Internal.Listen,+     module Happstack.Server.Internal.Types+    ) where++import Happstack.Server.Internal.Handler+import Happstack.Server.Internal.Listen+import Happstack.Server.Internal.Types++-- $impl+-- The Happstack HTTP implementation supports HTTP 1.0 and 1.1.+-- Multiple request on a connection including pipelining is supported.++-- $problems+-- Currently if a client sends an invalid HTTP request the whole+-- connection is aborted and no further processing is done.+--+-- When the connection times out Happstack closes it. In future it could+-- send a 408 response but this may be problematic if the sending+-- of a response caused the problem.

@@ -0,0 +1,127 @@+{-# LANGUAGE FlexibleInstances #-}++module Happstack.Server.Internal.MessageWrap (+	module Happstack.Server.Internal.MessageWrap+	,defaultInputIter+   ) where++import Control.Concurrent.MVar (tryTakeMVar, putMVar)+import Control.Monad.Trans (MonadIO(liftIO))+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Maybe+import Data.Int (Int64)+import Happstack.Server.Internal.Types as H+import Happstack.Server.Internal.Multipart+import Happstack.Server.Internal.RFC822Headers (parseContentType)+import Happstack.Server.SURI as SURI+import Happstack.Util.Common++queryInput :: SURI -> [(String, Input)]+queryInput uri = formDecode (case SURI.query uri of+                               '?':r -> r+                               xs    -> xs)++-- | 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 | (rqMethod req /= POST) && (rqMethod req /= PUT) = return ([], Nothing)+bodyInput bodyPolicy req =+  liftIO $+    do let ctype = getHeader "content-type" req >>= parseContentType . P.unpack+           getBS (Body bs) = bs+       if (isDecodable ctype)+          then do +            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+          else return ([], Nothing)+    where+      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++-- | 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.unEscape name,simpleInput $ SURI.unEscape val):rest+    where (pairString,qString')= split (=='&') qString+          (name,val)=split (=='=') pairString+          rest=if null qString' then [] else formDecode qString'++-- FIXME: no size limits on application/x-www-form-urlencoded yet+-- 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 (formDecode (L.unpack (L.take (maxRAM bp) inp)), Nothing)+        Just (ContentType "multipart" "form-data" ps) ->+            multipartDecode ((inputWorker bp) (maxDisk bp) (maxRAM bp) (maxHeader bp)) ps inp+        Just ct -> +            return ([], Just $ "decodeBody: unsupported content-type: " ++ show ct) -- unknown content-type, the user will have to+                     -- deal with it by looking at the raw content+        -- No content-type given, assume x-www-form-urlencoded+        Nothing -> return (formDecode (L.unpack (L.take (maxRAM bp) inp)), Nothing)++-- | 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 inputWorker ps inp =+    case lookup "boundary" ps of+         Just b  -> multipartBody inputWorker (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 SURI.unEscape . splitList '/' ++-- | Like 'Read' except Strings and Chars not quoted.+class (Read a)=>ReadString a where readString::String->a; readString =read ++instance ReadString Int +instance ReadString Double +instance ReadString Float +instance ReadString SURI.SURI where readString = read . show+instance ReadString [Char] where readString=id+instance ReadString Char where +    readString s= if length t==1 then head t else read t where t=trim s 

@@ -0,0 +1,503 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, 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.Monad                             ( MonadPlus(mzero, mplus), ap, liftM, msum+                                                 )+import Control.Monad.Trans                       ( MonadTrans, lift+                                                 , MonadIO, liftIO+                                                 )+import Control.Monad.Reader                      ( ReaderT(ReaderT), runReaderT+                                                 , MonadReader, ask, local+                                                 )+import Control.Monad.Writer                      ( WriterT(WriterT), runWriterT+                                                 , MonadWriter, tell, pass+                                                 , listens+                                                 )+import qualified Control.Monad.Writer            as Writer (listen) -- So that we can disambiguate 'Listen.listen'+import Control.Monad.State                       (MonadState, get, put)+import Control.Monad.Error                       ( ErrorT(ErrorT), runErrorT+                                                 , Error, MonadError, throwError+                                                 , catchError, mapErrorT+                                                 )+import Control.Monad.Maybe                       (MaybeT(MaybeT), runMaybeT)+import qualified Data.ByteString.Lazy.UTF8       as LU (fromString)+import Data.Char                                 (ord)+import Data.List                                 (inits, isPrefixOf, stripPrefix, tails)+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.Types                    (Request, Response, resultBS, setHeader)++-- | 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 (MonadIO m) => MonadIO (ServerPartT m) where+    liftIO = ServerPartT . liftIO+    {-# INLINE liftIO #-}++-- | 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) => 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)++instance (Error e, ServerMonad m) => ServerMonad (ErrorT e m) where+    askRq     = lift askRq+    localRq f = mapErrorT $ localRq f++-------------------------------+-- 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:+-- <http://hackage.haskell.org/packages/archive/category-extras/latest/doc/html/Control-Functor-Pointed.html>+-- 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 :: WriterT (FilterFun a) m b }+   deriving (Monad, MonadTrans, Functor)++instance (MonadIO m) => MonadIO (FilterT a m) where+    liftIO = FilterT . liftIO+    {-# INLINE liftIO #-}++-- | 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 (MonadIO m) => MonadIO (WebT m) where+    liftIO = WebT . liftIO+    {-# INLINE liftIO #-}++-- | '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 = outputTraceMessage s (mkFailMessage 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 (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) => 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 . runWriterT . unFilterT . runErrorT . unWebT++-- | For wrapping a 'WebT' back up.  @'mkWebT' . 'ununWebT' = 'id'@+mkWebT :: UnWebT m a -> WebT m a+mkWebT = WebT . ErrorT . FilterT . 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 => [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+    let res = setHeader "Content-Type" "text/html; charset=UTF-8" $+              resultBS 500 (LU.fromString (failHtml s))+    finishWith $ res++failHtml:: String->String+failHtml errString = +   "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">"+    ++ "<html><head><title>Happstack "+    ++ ver ++ " Internal Server Error</title></head>"+    ++ "<body><h1>Happstack " ++ ver ++ "</h1>"+    ++ "<p>Something went wrong here<br>"+    ++ "Internal server error<br>"+    ++ "Everything has stopped</p>"+    ++ "<p>The error was \"" ++ (escapeString errString) ++ "\"</p></body></html>"+    where ver = DV.showVersion Cabal.version++escapeString :: String -> String+escapeString str = concatMap encodeEntity str+    where+      encodeEntity :: Char -> String+      encodeEntity '<' = "&lt;"+      encodeEntity '>' = "&gt;"+      encodeEntity '&' = "&amp;"+      encodeEntity '"' = "&quot;"+      encodeEntity c+          | ord c > 127 = "&#" ++ show (ord c) ++ ";"+          | otherwise = [c]

@@ -0,0 +1,257 @@+module Happstack.Server.Internal.Multipart where++import           Control.Monad (MonadPlus(mplus), foldM)+import qualified Data.ByteString.Lazy.Char8    as L+import qualified Data.ByteString.Internal      as B+import           Data.ByteString.Lazy.Internal (ByteString(Chunk, Empty))+import           Data.ByteString.Lazy.Internal as L+import qualified Data.ByteString.Lazy.UTF8     as LU+import qualified Data.ByteString.Char8         as S+import           Data.List (intercalate)+import           Data.Maybe (fromMaybe)+import           Data.Int (Int64)+import           Text.ParserCombinators.Parsec (ParseError, parse)+import           Happstack.Server.Internal.Types (Input(..))+import           Happstack.Server.Internal.RFC822Headers ( ContentType(..), ContentDisposition(..), Header+                                                         , getContentDisposition, getContentType, pHeaders)+import           System.IO (Handle, hClose, openBinaryTempFile)++-- | similar to the normal 'span' function, except the predicate gets the whole rest of the lazy bytestring, not just one character.+--+-- TODO: this function has not been profiled.+spanS :: (L.ByteString -> Bool) -> L.ByteString -> (L.ByteString, L.ByteString)+spanS f cs0 = spanS' 0 cs0+  where spanS' n Empty = (Empty, Empty)+        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' n 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 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) ->+                  cont (BodyWork ctype ps b)++              cd -> return $ Failed Nothing ("Expected content-disposition: form-data but got " ++ show cd)++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) -> (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 #-}

@@ -0,0 +1,266 @@+-- #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 Data.Char+import Data.List+import Text.ParserCombinators.Parsec++type Header = (String, String)++pHeaders :: Parser [Header]+pHeaders = many pHeader++parseHeaders :: Monad m => SourceName -> String -> m [Header]+parseHeaders = parseM pHeaders++pHeader :: Parser Header+pHeader = +    do name <- many1 headerNameChar+       char ':'+       many ws1+       line <- lineString+       crLf+       extraLines <- many extraFieldLine+       return (map toLower name, concat (line:extraLines))++extraFieldLine :: Parser String+extraFieldLine = +    do sp <- ws1+       line <- lineString+       crLf+       return (sp:line)++--+-- * Parameters (for Content-type etc.)+--++showParameters :: [(String,String)] -> String+showParameters = concatMap f+    where f (n,v) = "; " ++ n ++ "=\"" ++ concatMap esc v ++ "\""+          esc '\\' = "\\\\"+          esc '"'  = "\\\""+          esc c | c `elem` ['\\','"'] = '\\':[c]+                | otherwise = [c]++p_parameter :: Parser (String,String)+p_parameter =+  do lexeme $ char ';'+     p_name <- lexeme $ p_token+     lexeme $ char '='+     -- Workaround for seemingly standardized web browser bug+     -- where nothing is escaped in the filename parameter+     -- of the content-disposition header in multipart/form-data+     let litStr = if p_name == "filename" +                   then buggyLiteralString+                   else literalString+     p_value <- litStr <|> p_token+     return (map toLower p_name, p_value)+++-- +-- * Content type+--++-- | A MIME media type value.+--   The 'Show' instance is derived automatically.+--   Use 'showContentType' to obtain the standard+--   string representation.+--   See <http://www.ietf.org/rfc/rfc2046.txt> for more+--   information about MIME media types.+data ContentType = +	ContentType {+                     -- | The top-level media type, the general type+                     --   of the data. Common examples are+                     --   \"text\", \"image\", \"audio\", \"video\",+                     --   \"multipart\", and \"application\".+                     ctType :: String,+                     -- | The media subtype, the specific data format.+                     --   Examples include \"plain\", \"html\",+                     --   \"jpeg\", \"form-data\", etc.+                     ctSubtype :: String,+                     -- | Media type parameters. On common example is+                     --   the charset parameter for the \"text\" +                     --   top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@.+                     ctParameters :: [(String, String)]+                    }+    deriving (Show, Read, Eq, Ord)++-- | Produce the standard string representation of a content-type,+--   e.g. \"text\/html; charset=ISO-8859-1\".+showContentType :: ContentType -> String+showContentType (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps++pContentType :: Parser ContentType+pContentType = +  do many ws1+     c_type <- p_token+     lexeme $ char '/'+     c_subtype <- lexeme $ p_token+     c_parameters <- many p_parameter+     return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters++-- | Parse the standard representation of a content-type.+--   If the input cannot be parsed, this function calls+--   'fail' with a (hopefully) informative error message.+parseContentType :: Monad m => String -> m ContentType+parseContentType = parseM pContentType "Content-type"++getContentType :: Monad m => [Header] -> m ContentType+getContentType hs = lookupM "content-type" hs >>= parseContentType++--+-- * Content transfer encoding+--++data ContentTransferEncoding =+	ContentTransferEncoding String+    deriving (Show, Read, Eq, Ord)++pContentTransferEncoding :: Parser ContentTransferEncoding+pContentTransferEncoding =+  do many ws1+     c_cte <- p_token+     return $ ContentTransferEncoding (map toLower c_cte)++parseContentTransferEncoding :: Monad m => String -> m ContentTransferEncoding+parseContentTransferEncoding = +    parseM pContentTransferEncoding "Content-transfer-encoding"++getContentTransferEncoding :: Monad m => [Header] -> m ContentTransferEncoding+getContentTransferEncoding hs = +    lookupM "content-transfer-encoding" hs >>= parseContentTransferEncoding++--+-- * Content disposition+--++data ContentDisposition =+	ContentDisposition String [(String, String)]+    deriving (Show, Read, Eq, Ord)++pContentDisposition :: Parser ContentDisposition+pContentDisposition =+  do many ws1+     c_cd <- p_token+     c_parameters <- many p_parameter+     return $ ContentDisposition (map toLower c_cd) c_parameters++parseContentDisposition :: Monad m => String -> m ContentDisposition+parseContentDisposition = parseM pContentDisposition "Content-disposition"++getContentDisposition :: Monad m => [Header] -> m ContentDisposition+getContentDisposition hs = +    lookupM "content-disposition" hs  >>= parseContentDisposition++--+-- * Utilities+--++parseM :: Monad m => Parser a -> SourceName -> String -> m a+parseM p n inp =+  case parse p n inp of+    Left e -> fail (show e)+    Right x -> return x++lookupM :: (Monad m, Eq a, Show a) => a -> [(a,b)] -> m b+lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n++-- +-- * Parsing utilities+--++-- | RFC 822 LWSP-char+ws1 :: Parser Char+ws1 = oneOf " \t"++lexeme :: Parser a -> Parser a+lexeme p = do x <- p; many ws1; return x++-- | RFC 822 CRLF (but more permissive)+crLf :: Parser String+crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r"++-- | One line+lineString :: Parser String+lineString = many (noneOf "\n\r")++literalString :: Parser String+literalString = do char '\"'+		   str <- many (noneOf "\"\\" <|> quoted_pair)+		   char '\"'+		   return str++-- No web browsers seem to implement RFC 2046 correctly,+-- since they do not escape double quotes and backslashes+-- in the filename parameter in multipart/form-data.+--+-- Note that this eats everything until the last double quote on the line.+buggyLiteralString :: Parser String+buggyLiteralString = +    do char '\"'+       str <- manyTill anyChar (try lastQuote)+       return str+  where lastQuote = do char '\"' +                       notFollowedBy (try (many (noneOf "\"") >> char '\"'))++headerNameChar :: Parser Char+headerNameChar = noneOf "\n\r:"++especials, tokenchar :: [Char]+especials = "()<>@,;:\\\"/[]?.="+tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials++p_token :: Parser String+p_token = many1 (oneOf tokenchar)++text_chars :: [Char]+text_chars = map chr ([1..9] ++ [11,12] ++ [14..127])++p_text :: Parser Char+p_text = oneOf text_chars++quoted_pair :: Parser Char+quoted_pair = do char '\\'+		 p_text

@@ -0,0 +1,51 @@+{-# LANGUAGE TemplateHaskell #-}+module Happstack.Server.Internal.Socket(acceptLite) where++import Happstack.Server.Internal.SocketTH(supportsIPv6)+import Language.Haskell.TH.Syntax+import Happstack.Util.HostAddress+import qualified Network as N+  ( PortID(PortNumber)+  , socketPort+  )+import qualified Network.Socket as S+  ( Socket(..)+  , PortNumber()+  , SockAddr(..)+  , HostName+  , accept+  , socketToHandle+  )+import System.IO++-- | alternative implementation of accept to work around EAI_AGAIN errors+acceptLite :: S.Socket -> IO (S.Socket, S.HostName, S.PortNumber)+acceptLite sock = do+  (sock', addr) <- S.accept sock+  (N.PortNumber p) <- N.socketPort sock'+  +  let peer = $(if supportsIPv6+                 then+                 return $ CaseE (VarE (mkName "addr")) +                            [Match +                             (ConP (mkName "S.SockAddrInet") +                              [WildP,VarP (mkName "ha")]) +                             (NormalB (AppE (VarE (mkName "showHostAddress")) +                                       (VarE (mkName "ha")))) []+                            ,Match (ConP (mkName "S.SockAddrInet6") [WildP,WildP,VarP (mkName "ha"),WildP])+                             (NormalB (AppE (VarE (mkName "showHostAddress6")) (VarE (mkName "ha")))) []+                            ,Match WildP (NormalB (AppE (VarE (mkName "error")) (LitE (StringL "Unsupported socket")))) []]+                 -- the above mess is the equivalent of this: +                 {-[| case addr of+                       (S.SockAddrInet _ ha)      -> showHostAddress ha+                       (S.SockAddrInet6 _ _ ha _) -> showHostAddress6 ha+                       _                          -> error "Unsupported socket"+                   |]-}+                 else+                 [| case addr of+                      (S.SockAddrInet _ ha)      -> showHostAddress ha+                      _                          -> error "Unsupported socket"+                 |])+                     +  return (sock', peer, p)+

@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}+module Happstack.Server.Internal.SocketTH(supportsIPv6) where+import Language.Haskell.TH++import Data.List+import Data.Maybe+import Network.Socket(SockAddr(..))++-- find out at compile time if the SockAddr6 / HostAddress6 constructors are available+supportsIPv6 :: Bool+supportsIPv6 = $(let c = ["Network.Socket.SockAddrInet6", "Network.Socket.Internal.SockAddrInet6"] ; d = ''SockAddr in+                 do TyConI (DataD _ _ _ cs _) <- reify d+                    if isJust (find (\(NormalC n _) -> show n `elem` c) cs)+                       then [| True |]+                       else [| False |] )

@@ -0,0 +1,59 @@+module Happstack.Server.Internal.TimeoutManager+    ( Manager+    , Handle+    , initialize+    , register+    , tickle+    , pause+    , resume+    , cancel+    ) where++import qualified Data.IORef as I+import Control.Concurrent (forkIO, threadDelay)+import Control.Monad (forever)+import qualified Control.Exception as E++-- FIXME implement stopManager++newtype Manager = Manager (I.IORef [Handle])+data Handle = Handle (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+                onTimeout `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+    let h = Handle onTimeout iactive+    I.atomicModifyIORef ref (\x -> (h : x, ()))+    return h++tickle, pause, resume, cancel :: Handle -> IO ()+tickle (Handle _ iactive) = I.writeIORef iactive Active+pause (Handle _ iactive) = I.writeIORef iactive Paused+resume = tickle+cancel (Handle _ iactive) = I.writeIORef iactive Canceled

@@ -0,0 +1,66 @@+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}+{- | +-- borrowed from snap-server. Check there periodically for updates.+-}+module Happstack.Server.Internal.TimeoutSocket where++import           Control.Concurrent            (ThreadId, forkIO, killThread, threadDelay, threadWaitWrite)+import           Control.Exception             (SomeException, catch, throw)+import           Control.Monad                 (liftM, when)+import qualified Data.ByteString.Char8         as B+import qualified Data.ByteString.Lazy.Char8    as L+import qualified Data.ByteString.Lazy.Internal as L+import qualified Data.ByteString               as S+import qualified Network.Socket.ByteString as N+import           Data.Word+import           Data.IORef+import           Data.List (foldl')+import           Data.Time.Clock.POSIX(POSIXTime, getPOSIXTime)+import           Happstack.Server.Internal.Clock (getApproximatePOSIXTime)+import qualified Happstack.Server.Internal.TimeoutManager as TM+import           Network.Socket (Socket, ShutdownCmd(..), shutdown)+import           Network.Socket.SendFile (Iter(..), ByteCount, Offset, sendFileIterWith')+import           Network.Socket.ByteString (sendAll)+import           Prelude hiding (catch)+import           System.IO (Handle, hClose, hIsEOF, hWaitForInput)+import           System.IO.Error (isDoesNotExistError)+import           System.IO.Unsafe (unsafeInterleaveIO)++sPutTickle :: TM.Handle -> Socket -> L.ByteString -> IO ()+sPutTickle thandle sock cs =+    do L.foldrChunks (\c rest -> sendAll sock c >> TM.tickle thandle >> rest) (return ()) cs+{-# 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 shutdown sock ShutdownReceive `catch` (\e -> when (not $ isDoesNotExistError e) (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

@@ -0,0 +1,393 @@+{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, 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,+     Conf(..), nullConf, result, resultBS,+     redirect, -- redirect_, redirect', redirect'_,+     isHTTP1_0, isHTTP1_1,+     RsFlags(..), nullRsFlags, noContentLength,+     HttpVersion(..), Length(..), Method(..), Headers, continueHTTP,+     Host, ContentType(..)+    ) where+++import Control.Monad.Error (Error(strMsg))+import Control.Monad.Trans (MonadIO(liftIO))+import Control.Concurrent.MVar+import qualified Data.Map as M+import Data.Data (Data)+import Data.IORef (IORef, atomicModifyIORef, readIORef)+import Data.Time.Format (FormatTime(..))+import Data.Typeable(Typeable)+import qualified Data.ByteString.Char8 as P+import Data.ByteString.Char8 (ByteString,pack)+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy.UTF8  as LU (fromString)+import Data.Maybe+import Data.List+import Happstack.Server.SURI+import Data.Char (toLower)++import Happstack.Server.Internal.RFC822Headers ( ContentType(..) )+import Happstack.Server.Internal.Cookie+import Happstack.Util.LogFormat (formatRequestCombined)+import System.Log.Logger (Priority(..), logM)+import Text.Show.Functions ()++-- | 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+continueHTTP :: Request -> Response -> Bool+--continueHTTP rq res = isHTTP1_1 rq && getHeader' connectionC rq /= Just closeC && rsfContentLength (rsFlags res)+continueHTTP rq res = (isHTTP1_0 rq && checkHeaderBS connectionC keepaliveC rq) ||+                      (isHTTP1_1 rq && not (checkHeaderBS connectionC closeC rq)) && (rsfLength (rsFlags res) /= NoContentLength)++-- | HTTP configuration+data Conf = Conf { port       :: Int -- ^ Port for the server to listen on.+                 , validator  :: Maybe (Response -> IO Response) -- ^ a function to validate the output on-the-fly+                 , logAccess  :: forall t. FormatTime t => Maybe (String -> String -> t -> String -> Int -> Integer -> String -> String -> IO ()) -- ^ function to log access requests (see also: 'logMAccess')+                 , timeout    :: Int -- ^ number of seconds to wait before killing an inactive thread+                 } ++-- | 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+                }++-- | log access requests using hslogger and apache-style log formatting+--+-- see also: 'Conf'+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+               deriving(Show,Read,Eq,Ord,Typeable,Data)++-- | an HTTP header+data HeaderPair +    = HeaderPair { hName :: ByteString     -- ^ header name+                 , hValue :: [ByteString]  -- ^ header value (or values if multiple occurances of the header are present)+                 } +      deriving (Read,Show)+-- | Combined headers.++-- | 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 that will include the content-length header+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 }++-- | 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      (rsValidator res)+    showsPrec _ res@SendFile{}  =+        showString   "================== Response ================" .+        showString "\nrsCode      = " . shows      (rsCode res)     .+        showString "\nrsHeaders   = " . shows      (rsHeaders res)  .+        showString "\nrsFlags     = " . shows      (rsFlags res)    .+        showString "\nrsValidator = " . shows      (rsValidator res).+        showString "\nsfFilePath  = " . shows      (sfFilePath res) .+        showString "\nsfOffset    = " . shows      (sfOffset res)   .+        showString "\nsfCount     = " . shows      (sfCount res)++-- 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 { rqMethod      :: Method,+                         rqPaths       :: [String],+                         rqUri         :: String,+                         rqQuery       :: String,+                         rqInputsQuery :: [(String,Input)],+                         rqInputsBody  :: MVar [(String,Input)],+                         rqCookies     :: [(String,Cookie)],+                         rqVersion     :: HttpVersion,+                         rqHeaders     :: Headers,+                         rqBody        :: MVar RqBody,+                         rqPeer        :: Host+                       } deriving(Typeable)++instance Show Request where+    showsPrec _ rq =+        showString   "================== Request =================" .+        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 "<<mvar>>" .+        showString "\nrqCookies     = " . shows      (rqCookies rq) .+        showString "\nrqVersion     = " . shows      (rqVersion rq) .+        showString "\nrqHeaders     = " . shows      (rqHeaders rq) .+        showString "\nrqBody        = " . showString "<<mvar>>" .+        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) +-- takeRequestBody rq = return (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++{-+takeRequestBody rq = +    do body <- atomicModifyIORef (rqBody rq) (\bdy -> (Nothing, bdy))+       newBD <- readIORef (rqBody rq)+       print newBD+       newBD `seq` return body+-}+-- | Converts a Request into a String representing the corresponding URL+rqURL :: Request -> String+rqURL rq = '/':intercalate "/" (rqPaths rq) ++ (rqQuery rq)++-- | a class for working with types that contain HTTP headers+class HasHeaders a where +    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 (vs1++vs2)++--------------------------------------------------------------+-- Retrieving header information+--------------------------------------------------------------++-- | Lookup header value. Key is case-insensitive.+getHeader :: HasHeaders r => String -> r -> Maybe ByteString+getHeader = getHeaderBS . pack++-- | Lookup header value. Key is a case-insensitive bytestring.+getHeaderBS :: HasHeaders r => ByteString -> r -> Maybe ByteString+getHeaderBS = getHeaderUnsafe . P.map toLower++-- | Lookup header value with a case-sensitive key. The key must be lowercase.+getHeaderUnsafe :: HasHeaders r => ByteString -> r -> Maybe ByteString+getHeaderUnsafe key var = listToMaybe =<< fmap hValue (getHeaderUnsafe' key var)++-- | Lookup header with a case-sensitive key. The key must be lowercase.+getHeaderUnsafe' :: HasHeaders r => ByteString -> r -> Maybe HeaderPair+getHeaderUnsafe' key = M.lookup key . headers++--------------------------------------------------------------+-- Querying header status+--------------------------------------------------------------++-- | Returns True if the associated key is found in the Headers.  The lookup+-- is case insensitive.+hasHeader :: HasHeaders r => String -> r -> Bool+hasHeader key r = isJust (getHeader key r)++-- | Acts as 'hasHeader' with ByteStrings+hasHeaderBS :: HasHeaders r => ByteString -> r -> Bool+hasHeaderBS key r = isJust (getHeaderBS key r)++-- | Acts as 'hasHeaderBS' but the key is case sensitive.  It should be+-- in lowercase.+hasHeaderUnsafe :: HasHeaders r => ByteString -> r -> Bool+hasHeaderUnsafe key r = isJust (getHeaderUnsafe' key r)++checkHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> Bool+checkHeaderBS key val = checkHeaderUnsafe (P.map toLower key) (P.map toLower val)++checkHeaderUnsafe :: HasHeaders r => ByteString -> ByteString -> r -> Bool+checkHeaderUnsafe key val r+    = case getHeaderUnsafe key r of+        Just val' | P.map toLower val' == val -> True+        _ -> False+++--------------------------------------------------------------+-- Setting header status+--------------------------------------------------------------++-- | Associates the key/value pair in the headers.  Forces the key to be+-- lowercase.+setHeader :: HasHeaders r => String -> String -> r -> r+setHeader key val = setHeaderBS (pack key) (pack val)++-- | Acts as 'setHeader' but with ByteStrings.+setHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r+setHeaderBS key val = setHeaderUnsafe (P.map toLower key) (HeaderPair key [val])++-- | Sets the key to the HeaderPair.  This is the only way to associate a key+-- with multiple values via the setHeader* functions.  Does not force the key+-- to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. +setHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r+setHeaderUnsafe key val = updateHeaders (M.insert key val)++--------------------------------------------------------------+-- Adding headers+--------------------------------------------------------------++-- | Add a key/value pair to the header.  If the key already has a value+-- associated with it, then the value will be appended.  +-- Forces the key to be lowercase.+addHeader :: HasHeaders r => String -> String -> r -> r+addHeader key val = addHeaderBS (pack key) (pack val)++-- | Acts as addHeader except for ByteStrings+addHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r+addHeaderBS key val = addHeaderUnsafe (P.map toLower key) (HeaderPair key [val])++-- | Add a key/value pair to the header using the underlying HeaderPair data+-- type.  Does not force the key to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. +addHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r+addHeaderUnsafe key val = updateHeaders (M.insertWith join key val)+    where join (HeaderPair k vs1) (HeaderPair _ vs2) = HeaderPair k (vs1++vs2)++-- | Creates a Response with the given Int as the status code and the provided+-- String as the body of the Response +result :: Int -> String -> Response+result code = resultBS code . 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"+

@@ -1,97 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--module Happstack.Server.MessageWrap where--import qualified Data.ByteString.Char8 as P-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Maybe-import Happstack.Server.HTTP.Types as H-import Happstack.Server.HTTP.Multipart-import Happstack.Server.SURI as SURI-import Happstack.Util.Common--queryInput :: SURI -> [(String, Input)]-queryInput uri = formDecode (case SURI.query uri of-                               '?':r -> r-                               xs    -> xs)--bodyInput :: Request -> [(String, Input)]-bodyInput req | (rqMethod req /= POST) && (rqMethod req /= PUT) = []-bodyInput req =-    let ctype = getHeader "content-type" req >>= parseContentType . P.unpack-        getBS (Body bs) = bs-    in decodeBody ctype (getBS $ rqBody req)----- | Decodes application\/x-www-form-urlencoded inputs.      -formDecode :: String -> [(String, Input)]-formDecode [] = []-formDecode qString = -    if null pairString then rest else -           (SURI.unEscape name,simpleInput $ SURI.unEscape val):rest-    where (pairString,qString')= split (=='&') qString-          (name,val)=split (=='=') pairString-          rest=if null qString' then [] else formDecode qString'--decodeBody :: Maybe ContentType-           -> L.ByteString-           -> [(String,Input)]-decodeBody ctype inp-    = case ctype of-        Just (ContentType "application" "x-www-form-urlencoded" _)-            -> formDecode (L.unpack inp)-        Just (ContentType "multipart" "form-data" ps)-            -> multipartDecode ps inp-        Just _ -> [] -- unknown content-type, the user will have to-                     -- deal with it by looking at the raw content-        -- No content-type given, assume x-www-form-urlencoded-        Nothing -> formDecode (L.unpack inp)---- | Decodes multipart\/form-data input.-multipartDecode :: [(String,String)] -- ^ Content-type parameters-                -> L.ByteString        -- ^ Request body-                -> [(String,Input)]  -- ^ Input variables and values.-multipartDecode ps inp =-    case lookup "boundary" ps of-         Just b -> case parseMultipartBody b inp of-                        Just (MultiPart bs) -> map bodyPartToInput bs-                        Nothing -> [] -- FIXME: report parse error-         Nothing -> [] -- FIXME: report that there was no boundary--bodyPartToInput :: BodyPart -> (String,Input)-bodyPartToInput (BodyPart hs b) =-    case getContentDisposition hs of-              Just (ContentDisposition "form-data" ps) ->-                  (fromMaybe "" $ lookup "name" ps,-                   Input { inputValue = b,-                           inputFilename = lookup "filename" ps,-                           inputContentType = ctype })-              _ -> ("ERROR",simpleInput "ERROR") -- FIXME: report error-    where ctype = fromMaybe defaultInputType (getContentType hs)---- | Packs a string into an Input of type "text/plain"-simpleInput :: String -> Input-simpleInput v-    = Input { inputValue = L.pack v-            , inputFilename = Nothing-            , inputContentType = defaultInputType-            }---- | The default content-type for variables.-defaultInputType :: ContentType-defaultInputType = ContentType "text" "plain" [] -- FIXME: use some default encoding?---- | Get the path components from a String.-pathEls :: String -> [String]-pathEls = (drop 1) . map SURI.unEscape . splitList '/' ---- | Like 'Read' except Strings and Chars not quoted.-class (Read a)=>ReadString a where readString::String->a; readString =read --instance ReadString Int -instance ReadString Double -instance ReadString Float -instance ReadString SURI.SURI where readString = read . show-instance ReadString [Char] where readString=id-instance ReadString Char where -    readString s= if length t==1 then head t else read t where t=trim s 

@@ -1,214 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances,-             OverlappingInstances, UndecidableInstances, TypeSynonymInstances #-}---  -module Happstack.Server.MinHaXML where--- Copyright (c) Happstack.com 2009; (c) HAppS.org 2005. All Rights Reserved.--import Prelude hiding (elem, pi)--import Text.XML.HaXml.Types as Types-import Text.XML.HaXml.Escape-import Text.XML.HaXml.Pretty as Pretty-import Text.XML.HaXml.Verbatim as Verbatim-import Happstack.Util.Common-import System.Time--import Happstack.Data.Xml as Xml-import Happstack.Data.Xml.HaXml--type StyleURL=String-data StyleSheet = NoStyle-                | CSS {styleURL::StyleURL} -                | XSL {styleURL::StyleURL} deriving (Read,Show)-hasStyleURL :: StyleSheet -> Bool-hasStyleURL NoStyle = False-hasStyleURL _ = True -type Element = Types.Element--	--isCSS :: StyleSheet -> Bool-isCSS (CSS _)=True-isCSS _ = False-isXSL :: StyleSheet -> Bool-isXSL = not.isCSS--t :: Name -> [(Name, String)] -> CharData -> Types.Element-t=textElem-l :: Name -> [(Name, String)] -> [Types.Element] -> Types.Element-l=listElem-e :: Name -> [(Name, String)] -> Types.Element-e=emptyElem-(</<) :: Name-         -> [(Name, String)]-         -> [Types.Element]-         -> Types.Element-(</<)=l-(<>) :: Name -> [(Name, String)] -> CharData -> Types.Element-(<>)=t----xmlElem :: (t -> [Content])-           -> Name-           -> [(Name, String)]-           -> t-           -> Types.Element-xmlElem f = \name attrs val -> xmlelem name attrs (f val)-	where -	xmlelem name = Types.Elem name . map (uncurry attr)-	attr name val= (name,AttValue [Left val])--textElem :: Name -> [(Name, String)] -> CharData -> Types.Element-textElem = xmlElem (return.CString True)-emptyElem :: Name -> [(Name, String)] -> Types.Element-emptyElem = \n a->xmlElem id n a []-listElem :: Name-            -> [(Name, String)]-            -> [Types.Element]-            -> Types.Element-listElem = xmlElem $ map CElem--cdataElem :: CharData -> Content-cdataElem = CString  False----	     Document (simpleProlog xsl) [] $ xmlEscape stdXmlEscaper root-simpleDocOld :: StyleSheet -> Types.Element -> String-simpleDocOld xsl = show . document . -                flip (Document (simpleProlog xsl) []) [] . xmlStdEscape--simpleDoc :: StyleSheet -> Types.Element -> String-simpleDoc style elem = ("<?xml version='1.0' encoding='UTF-8' ?>\n"++-                      if hasStyleURL style then pi else "") ++-                     (verbatim $ xmlStdEscape elem)-    where typeText=if isCSS style then "text/css" else "text/xsl"-          pi= "<?xml-stylesheet type=\""++ typeText  ++ -              "\" href=\""++styleURL style++"\" ?>\n"---simpleDoc' :: StyleSheet -> Types.Element -> String-simpleDoc' style elem = (if hasStyleURL style then pi else "") ++-                        (verbatim $ xmlStdEscape elem)-    where typeText=if isCSS style then "text/css" else "text/xsl"-          pi= "<?xml-stylesheet type=\""++ typeText  ++ -              "\" href=\""++styleURL style++"\" ?>\n"----xmlEscaper :: XmlEscaper-xmlEscaper=stdXmlEscaper-xmlStdEscape :: Types.Element -> Types.Element-xmlStdEscape = xmlEscape stdXmlEscaper-verbim :: (Verbatim a) => a -> String-verbim = verbatim--simpleProlog :: StyleSheet -> Prolog-simpleProlog style = -    Prolog -    (Just (XMLDecl "1.0" -	   (Just $ EncodingDecl "UTF-8") -	   Nothing -- standalone declaration-	  ))-    [] Nothing-           (if url=="" then [] else [pi])-	where-	pi = PI ("xml-stylesheet", "type=\""++typeText++"\" href=\""++url++"\"")-	typeText = if isCSS style then "text/css" else "text/xsl"-	url=if hasStyleURL style then styleURL style else ""--nonEmpty :: Name -> String -> Maybe Types.Element-nonEmpty name val = if val=="" then Nothing-					else Just $ textElem name [] val--getRoot :: Document -> Types.Element-getRoot (Document _ _ root _) = root----toXML .< "App" attrs ./>---toXML .< "App" attrs .> []-data XML a = XML StyleSheet a--class ToElement x where toElement::x->Types.Element-		-instance (ToElement x) => ToElement (Maybe x) where -    toElement = maybe (emptyElem "Nothing" []) toElement--instance ToElement String where toElement = textElem "String" []-instance ToElement Types.Element where toElement = id-instance ToElement CalendarTime where -    toElement = recToEl "CalendarTime" -                [attrFS "year" ctYear-                ,attrFS "month" (fromEnum.ctMonth)-                ,attrFS "day" ctDay-                ,attrFS "hour" ctHour-                ,attrFS "min" ctMin-                ,attrFS "sec" ctSec-                ,attrFS "time" time -                ] []-        where time = epochPico--instance ToElement Int where toElement = toElement . show-instance ToElement Integer where toElement = toElement . show-instance ToElement Float where toElement = toElement . show-instance ToElement Double where toElement = toElement . show---instance (Xml a) => ToElement a where-    toElement = un . head . map toHaXml . toXml-        where-        un (CElem el) = el-        un _ = error "Case not handled in Xml toElement instance"--wrapElem :: (ToElement x) => Name -> x -> Types.Element-wrapElem tag x= listElem tag [] [toElement x]-elF :: (ToElement b) => Name -> (a -> b) -> a -> Types.Element-elF tag f = wrapElem tag.f --- label !<=! field = wrapField label field-attrF :: t1 -> (t -> String) -> t -> (t1, String)-attrF name f rec = (name,quoteEsc $ f rec)-attrFS :: (Show a) => t1 -> (t -> a) -> t -> (t1, String)-attrFS name f rec = (name,quoteEsc $ show $ f rec)-attrFMb :: (a -> String)-           -> String-           -> (a1 -> Maybe a)-           -> a1-           -> (String, String)-attrFMb r name f = maybe ("","") (\x->(name,quoteEsc $ r x)) . f ----(\x->(name,quoteEsc $ r x)) . f ---(name,quoteEsc $ show $ f rec)--quoteEsc :: String -> String-quoteEsc [] = []-quoteEsc ('"':list) = "&quot;" ++ quoteEsc list-quoteEsc (x:xs) = x:quoteEsc xs----quotescape \\ and " \"--recToEl :: Name-           -> [a -> (String, String)]-           -> [a -> Types.Element]-           -> a-           -> Types.Element-recToEl name attrs els rec = listElem name attrs' (revmap rec els)-    where-    attrs' = filter (\ (x,_)->not $ null x) (revmap rec attrs)-listToEl :: (ToElement a) =>-            Name -> [(Name, String)] -> [a] -> Types.Element-listToEl name attrs = listElem name attrs . map toElement --toAttrs :: t -> [(t1, t -> t2)] -> [(t1, t2)]-toAttrs x = map (\ (s,f)->(s, f x)) --{---toElement rules:-1. if the attr is an instance of toElement then it is a child.-2. if it named and is type string then it is shown that way.-3. if it named and has non-string type then use show on the value.-4. if the attributes are not named then use the type as the label and-   make the text child be a show of the object.---}---newtype ElString = ElString {elString::String} deriving (Eq,Ord,Read,Show)

@@ -0,0 +1,86 @@+{-# 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+      -- * WebMonad+    , WebMonad(..)+    , escape+    , escape' +      -- * MonadPlus helpers+    , require+    , requireM+    ) where++import Control.Monad                     (MonadPlus(mzero))+import Control.Monad.Trans               (MonadIO(..),MonadTrans(lift))+import qualified Data.ByteString.Char8   as B+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) => Happstack m+++instance (Functor m, Monad m, MonadPlus m, MonadIO m) => Happstack (ServerPartT 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++-- | 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++

@@ -1,171 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}-module Happstack.Server.Parts(-    compressedResponseFilter-   ,gzipFilter-   ,deflateFilter-   ,encodings-) where-import Happstack.Server.SimpleHTTP-import Text.ParserCombinators.Parsec-import Control.Monad-import Data.Maybe-import Data.List-import qualified Data.ByteString.Char8 as BS-import qualified Codec.Compression.GZip as GZ-import qualified Codec.Compression.Zlib as Z---- | reads the \"Accept-Encoding\" header.  Then, if possible--- will compress the response body with methods "gzip" or "deflate"------ Returns the name of the coding chosen-compressedResponseFilter::-    (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m)-    => m String-compressedResponseFilter = do-    getHeaderM "Accept-Encoding" >>=-        (maybe (return "identity") installHandler)--  where-    badEncoding = "Encoding returned not in the list of known encodings"--    installHandler accept = do-      let eEncoding = bestEncoding $ BS.unpack accept-      (coding,action) <- case eEncoding of-          Left _ -> do-            setResponseCode 406-            finishWith $ toResponse ""--          Right a -> return (a, fromMaybe (fail badEncoding)-                                          (lookup a allEncodingHandlers))--      setHeaderM "Content-Encoding" coding-      action-      return coding----- | compresses the body of the response with gzip.--- does not set any headers.-gzipFilter::(FilterMonad Response m) => m()-gzipFilter = do-    composeFilter (\r -> r{rsBody = GZ.compress $ rsBody r})---- | compresses the body of the response with zlib's--- deflate method--- does not set any headers.-deflateFilter::(FilterMonad Response m) => m()-deflateFilter = do-    composeFilter (\r -> r{rsBody = Z.compress $ rsBody r})---- | based on the rules describe in rfc2616 sec. 14.3-bestEncoding :: String -> Either String String-bestEncoding encs = do-        encList<-either (Left . show) (Right) $ parse encodings "" encs-        case acceptable encList of-            [] -> Left "no encoding found"-            a -> Right $ head a-    where-        -- first intersect with the list of encodings we know how to deal with at all-        knownEncodings:: [(String,Maybe Double)] -> [(String, Maybe Double)]-        knownEncodings m = intersectBy (\x y->fst x == fst y) m (map (\x -> (x,Nothing)) allEncodings)-        -- this expands the wildcard, by figuring out if we need to include "identity" in the list-        -- Then it deletes the wildcard entry, drops all the "q=0" entries (which aren't allowed).-        ---        -- note this implementation is a little conservative.  if someone were to specify "*"-        -- without a "q" value, it would be this server is willing to accept any format at all.-        -- We pretty much assume we can't send them /any/ format and that they really-        -- meant just "identity" this seems safe to me.-        knownEncodings':: [(String,Maybe Double)] -> [(String, Maybe Double)]-        knownEncodings' m = filter dropZero $ deleteBy (\(a,_) (b,_)->a==b) ("*",Nothing) $-            case lookup "*" (knownEncodings m) of-                Nothing -> addIdent $ knownEncodings m-                Just (Just a) | a>0 -> addIdent $ knownEncodings m-                              | otherwise -> knownEncodings m-                Just (Nothing) -> addIdent $ knownEncodings m-        dropZero (_, Just a) | a==0 = False-                          | otherwise = True-        dropZero (_, Nothing) = True-        addIdent:: [(String,Maybe Double)] -> [(String, Maybe Double)]-        addIdent m = if isNothing $ lookup "identity" m-            then m ++ [("identity",Nothing)]-            else m-        -- finally we sort the list of available encodings.-        acceptable:: [(String,Maybe Double)] -> [String]-        acceptable l = map fst $ sortBy (flip cmp) $  knownEncodings'  l-        -- let the client choose but break ties with gzip-        encOrder = reverse $ zip (reverse allEncodings) [1..]-        m0 = maybe (0.0::Double) id-        cmp (s,mI) (t,mJ) | m0 mI == m0 mJ-            = compare (m0 $ lookup s encOrder) (m0 $ lookup t encOrder)-                          | otherwise = compare (m0 mI) (m0 mJ)---allEncodingHandlers:: (FilterMonad Response m) => [(String, m ())]-allEncodingHandlers = zip allEncodings handlers--allEncodings :: [String]-allEncodings =-    ["gzip"-    ,"x-gzip"---    ,"compress" -- as far as I can tell there is no haskell library that supports this---    ,"x-compress" -- as far as I can tell, there is no haskell library that supports this-    ,"deflate"-    ,"identity"-    ,"*"-    ]--handlers::(FilterMonad Response m) => [m ()]-handlers =-    [gzipFilter-    ,gzipFilter---    ,compressFilter---    ,compressFilter-    ,deflateFilter-    ,return ()-    ,fail "chose * as content encoding"-    ]---- | unsupported:  a parser for the Accept-Encoding header-encodings :: GenParser Char st [([Char], Maybe Double)]-encodings = ws >> (encoding1 `sepBy` try sep) >>= (\x -> ws >> eof >> return x)-    where-        ws :: 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--

@@ -0,0 +1,92 @@+{-# 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++

@@ -0,0 +1,289 @@+{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, ScopedTypeVariables #-}+-- | Functions and classes related to generating a 'Response' and setting the response code. For detailed instruction see the Happstack Crash Course: <http://happstack.com/docs/crashcourse/HelloWorld.html#response_code>+module Happstack.Server.Response +    ( -- * Converting values to a 'Response'+      ToMessage(..)+    , flatten+    , toResponseBS+      -- * Setting the Response Code+    , ok+    , noContent+    , internalServerError+    , badGateway+    , badRequest+    , unauthorized+    , forbidden+    , notFound+    , 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.Monads         (FilterMonad(composeFilter))+import           Happstack.Server.Types          (Response(..), Request(..), nullRsFlags, getHeader, noContentLength, redirect, result, setHeader, setHeaderBS)+import           Happstack.Server.SURI           (ToSURI)+import           System.Locale                   (defaultTimeLocale)+import           System.Time                     (CalendarTime, formatCalendarTime)+import qualified Text.Blaze                      as Blaze+import qualified Text.Blaze.Renderer.Utf8        as Blaze+import           Text.Html                       (Html, renderHtml)+import qualified Text.XHtml                      as XHtml (Html, renderHtml)++-- | A low-level function to build a 'Response' from a content-type+-- and a 'ByteString'.+--+-- Creates a 'Response' in a manner similar to the 'ToMessage' class,+-- but without requiring an instance declaration.+-- +-- example:+-- +-- > import Data.ByteString.Char8 as C+-- > import Data.ByteString.Lazy.Char8 as L+-- > import Happstack.Server+-- >+-- > main = simpleHTTP nullConf $ ok $ toResponseBS (C.pack "text/plain") (L.pack "hello, world")+--+-- (note: 'C.pack' and 'L.pack' only work for ascii. For unicode strings you would need to use @utf8-string@, @text@, or something similar to create a valid 'ByteString').+toResponseBS :: B.ByteString -- ^ content-type+             -> L.ByteString -- ^ response body+             -> Response+toResponseBS contentType message =+    let res = Response 200 M.empty nullRsFlags message Nothing+    in setHeaderBS (B.pack "Content-Type") contentType res+++-- | 'toResponse' will convert a value into a 'Response' body,+-- set the @content-type@, and set the default response code for that type.+--+-- 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!"+--+-- 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+{-++-- 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 :: CalendarTime -- ^ mod-time for the 'Response' (MUST NOT be later than server's time of message origination)+                -> Request -- ^ incoming request (used to check for if-modified-since)+                -> Response -- ^ Response to send if there are modifications+                -> Response+ifModifiedSince modTime request response =+    let repr = formatCalendarTime defaultTimeLocale "%a, %d %b %Y %X GMT" modTime+        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 @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++-- | 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 @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 @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 @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 @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