packages feed

happstack-server 0.2.1 → 7.9.3

raw patch · 61 files changed

Files

+ README.md view
@@ -0,0 +1,13 @@+# happstack-server [![Hackage Status](https://img.shields.io/hackage/v/happstack-server.svg)][hackage]++[hackage]: https://hackage.haskell.org/package/happstack-server++Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course http://happstack.com/docs/crashcourse/index.html.++## Install++There are packages available on [hackage][] and [stack](https://www.stackage.org/lts-3.12/package/happstack-server-7.4.5).++## Documentation ++Please refer to the [Documentation on Hackage][hackage].
Setup.hs view
@@ -1,3 +1,3 @@ #!/usr/bin/env runhaskell import Distribution.Simple-main = defaultMainWithHooks defaultUserHooks+main = defaultMainWithHooks simpleUserHooks
happstack-server.cabal view
@@ -1,108 +1,147 @@ Name:                happstack-server-Version:             0.2.1+Version:             7.9.3 Synopsis:            Web related tools and services.-Description:         Web framework+Description:         Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course <http://happstack.com/docs/crashcourse/index.html> License:             BSD3 License-file:        COPYING Author:              Happstack team, HAppS LLC Maintainer:          Happstack team <happs@googlegroups.com> homepage:            http://happstack.com-Category:            Web, Distributed Computing+Category:            Web, Happstack Build-Type:          Simple-Cabal-Version:       >= 1.4+Cabal-Version:       >= 1.10+Extra-Source-Files:  tests/Happstack/Server/Tests.hs README.md -Flag base4-    Description: Choose the even newer, even smaller, split-up base package.+tested-with:+  GHC == 9.14.1+  GHC == 9.12.2+  GHC == 9.10.2+  GHC == 9.8.2+  GHC == 9.6.7+  GHC == 9.4.8+  GHC == 9.2.8+  GHC == 9.0.2+  GHC == 8.10.7+  GHC == 8.8.4+  GHC == 8.6.5+  GHC == 8.4.4+  GHC == 8.2.2+  GHC == 8.0.2 -Flag tests-    Description: Build the testsuite, and include the tests in the library-    Default: False+source-repository head+    type:     git+    location: https://github.com/Happstack/happstack-server.git -Library+flag network-uri+    description: Get Network.URI from the network-uri package+    default: True +Library+  Default-language:    Haskell2010   Exposed-modules:                        Happstack.Server+                       Happstack.Server.Auth                        Happstack.Server.Cookie-                       Happstack.Server.HTTP.Client-                       Happstack.Server.HTTP.Types-                       Happstack.Server.HTTP.LowLevel-                       Happstack.Server.HTTP.FileServe-                       Happstack.Server.SimpleHTTP-                       Happstack.Server.JSON-                       Happstack.Server.MessageWrap-                       Happstack.Server.MinHaXML+                       Happstack.Server.Compression+                       Happstack.Server.Error+                       Happstack.Server.FileServe+                       Happstack.Server.FileServe.BuildingBlocks+                       Happstack.Server.I18N+                       Happstack.Server.Internal.Compression+                       Happstack.Server.Internal.Cookie+                       Happstack.Server.Internal.Handler+                       Happstack.Server.Internal.Types+                       Happstack.Server.Internal.Listen+                       Happstack.Server.Internal.LowLevel+                       Happstack.Server.Internal.LogFormat+                       Happstack.Server.Internal.MessageWrap+                       Happstack.Server.Internal.Multipart+                       Happstack.Server.Internal.RFC822Headers+                       Happstack.Server.Internal.Socket+                       Happstack.Server.Internal.TimeoutIO+                       Happstack.Server.Internal.TimeoutManager+                       Happstack.Server.Internal.TimeoutSocket+                       Happstack.Server.Internal.Monads+                       Happstack.Server.Monads+                       Happstack.Server.Response+                       Happstack.Server.Routing+                       Happstack.Server.RqData                        Happstack.Server.SURI-                       Happstack.Server.XSLT-                       Happstack.Server.StdConfig-                       Happstack.Server.Parts-  if flag(tests)-    Exposed-modules:   -                       Happstack.Server.Tests-  Other-modules:       -                       Happstack.Server.S3-                       Happstack.Server.HTTPClient.HTTP-                       Happstack.Server.HTTPClient.Stream-                       Happstack.Server.HTTPClient.TCP-                       Happstack.Server.HTTP.Clock-                       Happstack.Server.HTTP.Handler-                       Happstack.Server.HTTP.LazyLiner-                       Happstack.Server.HTTP.Listen-                       Happstack.Server.HTTP.Multipart-                       Happstack.Server.HTTP.RFC822Headers-                       Happstack.Server.HTTP.Socket-                       Happstack.Server.HTTP.SocketTH+                       Happstack.Server.SimpleHTTP+                       Happstack.Server.Types+                       Happstack.Server.Validation+  Other-modules:+                       Happstack.Server.Internal.Clock+                       Happstack.Server.Internal.LazyLiner                        Happstack.Server.SURI.ParseURI                        Paths_happstack_server -  Build-Depends:       base,+  if flag(network-uri)+     build-depends:    network     >= 3.0.0 && < 3.3,+                       network-uri >= 2.6 && < 2.7+  else+     build-depends:    network               < 2.6+  Build-Depends:       base                   >= 4    && < 5,+                       base64-bytestring      >= 1.0  && < 1.3,+                       blaze-html             >= 0.5  && < 0.10,                        bytestring,                        containers,-                       directory,+                       directory              >=1.2,+                       exceptions,                        extensible-exceptions,-                       HaXml >= 1.13 && < 1.14,-                       hslogger >= 1.0.2,-                       happstack-data >= 0.2.1 && < 0.3,-                       happstack-util >= 0.2.1 && < 0.3,+                       filepath,+                       hslogger               >= 1.0.2,                        html,-                       MaybeT,-                       mtl,-                       network,-                       old-locale,-                       old-time,-                       parsec < 3,+                       monad-control          >= 1.0  && < 1.1,+                       mtl                    >= 2.2  && < 2.4,+                       parsec                            < 4,                        process,-                       template-haskell,-                       time,-                       xhtml,+                       sendfile               >= 0.7.1 && < 0.8,+                       system-filepath        >= 0.3.1,+                       syb,+                       text                   >= 0.10  && < 2.2,+                       time                   >= 1.5,+                       threads                >= 0.5,+                       transformers           >= 0.1.3 && < 0.7,+                       transformers-base      >= 0.4   && < 0.5,+                       utf8-string            >= 0.3.4 && < 1.1,+                       xhtml                              < 3000.4,                        zlib    hs-source-dirs:      src-  if flag(tests)-    hs-source-dirs:    tests    if !os(windows)      Build-Depends:    unix      cpp-options:      -DUNIX-  if flag(base4)-    Build-Depends:     base >= 4 && < 5, syb -  if flag(tests)-    Build-Depends:     HUnit+  if impl(ghc < 8.6)+     Default-Extensions: MonadFailDesugaring -  Extensions:          TemplateHaskell, DeriveDataTypeable, MultiParamTypeClasses,-                       TypeFamilies, FlexibleContexts, OverlappingInstances,-                       FlexibleInstances, UndecidableInstances, ScopedTypeVariables,-                       TypeSynonymInstances, PatternGuards+  Other-Extensions:    DeriveDataTypeable, MultiParamTypeClasses,+                       TypeFamilies, FlexibleContexts,+                       FlexibleInstances, UndecidableInstances,+                       ScopedTypeVariables, TypeSynonymInstances, PatternGuards                        CPP, ForeignFunctionInterface-  ghc-options:         -Wall-  GHC-Prof-Options:    -auto-all+  ghc-options:         -Wall -fwarn-tabs+  -- The policy is to support GHC versions no older than the GHC stable+  -- branch that was used by the latest Haskell Platform release+  -- available 18 months ago. In order to avoid people spending time+  -- keeping the build working for older versions, we tell Cabal that+  -- it shouldn't allow builds with them.+  if impl(ghc < 8.0)+    buildable: False -Executable happstack-server-tests+Test-Suite happstack-server-tests+  Default-language:    Haskell2010+  Type: exitcode-stdio-1.0   Main-Is: Test.hs+  Other-Modules: Happstack.Server.Tests   GHC-Options: -threaded-  Build-depends: HUnit-  hs-source-dirs: tests, src-  if flag(tests)-    Buildable: True-  else-    Buildable: False+  hs-source-dirs: tests+  Build-depends: HUnit,+                 base >= 4    && < 5,+                 bytestring,+                 containers,+                 happstack-server,+                 parsec < 4,+                 zlib
src/Happstack/Server.hs view
@@ -1,15 +1,91 @@-module Happstack.Server -(module Happstack.Server.XSLT-,module Happstack.Server.SimpleHTTP-,module Happstack.Server.HTTP.Client-,module Happstack.Server.MessageWrap-,module Happstack.Server.HTTP.FileServe-,module Happstack.Server.StdConfig)-where-import Happstack.Server.HTTP.Client-import Happstack.Server.StdConfig-import Happstack.Server.XSLT-import Happstack.Server.SimpleHTTP-import Happstack.Server.MessageWrap-import Happstack.Server.HTTP.FileServe+{- |+Module      :  Happstack.Server+Copyright   :  (c) Happstack.com 2010; (c) HAppS Inc 2007+License     :  BSD3 +Maintainer  :  Happstack team <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+    ( -- * HTTP Server+      module Happstack.Server.SimpleHTTP+    -- * Request Routing+    , module Happstack.Server.Routing+    -- * Creating Responses+    , module Happstack.Server.Response+    -- * Looking up values in Query String, Request Body, and Cookies+    , module Happstack.Server.RqData+    -- * Create and Set Cookies (see also "Happstack.Server.RqData")+    , module Happstack.Server.Cookie+    -- * File Serving+    , module Happstack.Server.FileServe+    -- * HTTP Realm Authentication+    , module Happstack.Server.Auth+    -- * Error Handling+    , module Happstack.Server.Error+    -- * I18N+    , module Happstack.Server.I18N+    -- * Web-related Monads+    , module Happstack.Server.Monads+    -- * Output Validation+    , module Happstack.Server.Validation+    -- * HTTP Types+    , module Happstack.Server.Types+--    , module Happstack.Server.Internal.Monads+    )+    where++import Happstack.Server.SimpleHTTP       (simpleHTTP+                                         , simpleHTTP'+                                         , simpleHTTP''+                                         , simpleHTTPWithSocket+                                         , simpleHTTPWithSocket'+                                         , bindPort+                                         , bindIPv4+                                         , parseConfig+                                         , waitForTermination+                                         )+import Happstack.Server.FileServe+import Happstack.Server.Monads+import Happstack.Server.Auth+import Happstack.Server.Cookie+import Happstack.Server.Error+import Happstack.Server.I18N+import Happstack.Server.Response+import Happstack.Server.Routing+import Happstack.Server.RqData+import Happstack.Server.Validation+import Happstack.Server.Types+-- import Happstack.Server.Internal.Monads
+ src/Happstack/Server/Auth.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE FlexibleContexts #-}+-- | Support for basic access authentication <http://en.wikipedia.org/wiki/Basic_access_authentication>+module Happstack.Server.Auth where++import Data.Foldable (foldl')+import Data.Bits (xor, (.|.))+import Data.Maybe (fromMaybe)+import Control.Monad                             (MonadPlus(mzero, mplus))+import Data.ByteString.Base64                    as Base64+import qualified Data.ByteString                 as BS+import qualified Data.ByteString.Char8           as B+import qualified Data.Map                        as M+import Happstack.Server.Monads                   (Happstack, escape, getHeaderM, setHeaderM)+import Happstack.Server.Response                 (unauthorized, toResponse)++-- | A simple HTTP basic authentication guard.+--+-- If authentication fails, this part will call 'mzero'.+-- +-- example:+--+-- > main = simpleHTTP nullConf $ +-- >  msum [ basicAuth "127.0.0.1" (fromList [("happstack","rocks")]) $ ok "You are in the secret club"+-- >       , ok "You are not in the secret club." +-- >       ]+-- +basicAuth :: (Happstack m) =>+   String -- ^ the realm name+   -> M.Map String String -- ^ the username password map+   -> m a -- ^ the part to guard+   -> m a+basicAuth realmName authMap = basicAuthBy (validLoginPlaintext authMap) realmName+++-- | Generalized version of 'basicAuth'.+--+-- The function that checks the username password combination must be+-- supplied as first argument.+--+-- example:+--+-- > main = simpleHTTP nullConf $+-- >  msum [ basicAuth' (validLoginPlaintext (fromList [("happstack","rocks")])) "127.0.0.1" $ ok "You are in the secret club"+-- >       , ok "You are not in the secret club."+-- >       ]+--+basicAuthBy :: (Happstack m) =>+   (B.ByteString -> B.ByteString -> Bool) -- ^ function that returns true if the name password combination is valid+   -> String -- ^ the realm name+   -> m a -- ^ the part to guard+   -> m a+basicAuthBy validLogin realmName xs = basicAuthImpl `mplus` xs+  where+    basicAuthImpl = do+        aHeader <- getHeaderM "authorization"+        case aHeader of+            Nothing -> err+            Just x ->+                do (name, password) <- parseHeader x+                   if B.length password > 0+                      && B.head password == ':'+                      && validLogin name (B.tail password)+                     then mzero+                     else err+    parseHeader h =+      case Base64.decode . B.drop 6 $ h of+        (Left _)   -> err+        (Right bs) -> return (B.break (':'==) bs)+    headerName  = "WWW-Authenticate"+    headerValue = "Basic realm=\"" ++ realmName ++ "\""+    err :: (Happstack m) => m a+    err = escape $ do+            setHeaderM headerName headerValue+            unauthorized $ toResponse "Not authorized"+++-- | Function that looks up the plain text password for username in a+-- Map and returns True if it matches with the given password.+--+-- Note: The implementation is hardened against timing attacks but not+-- completely safe. Ideally you should build your own predicate, using+-- a robust constant-time equality comparison from a cryptographic+-- library like sodium.+validLoginPlaintext ::+  M.Map String String -- ^ the username password map+  -> B.ByteString -- ^ the username+  -> B.ByteString -- ^ the password+  -> Bool+validLoginPlaintext authMap name password = fromMaybe False $ do+    r <- M.lookup (B.unpack name) authMap+    pure (constTimeEq (B.pack r) password)+  where+    -- (Mostly) constant time equality of bytestrings to prevent timing attacks by testing out passwords. This still+    -- allows to extract the length of the configured password via timing attacks. This implementation is still brittle+    -- in the sense that it relies on GHC not unrolling or vectorizing the loop.+    {-# NOINLINE constTimeEq #-}+    constTimeEq :: BS.ByteString -> BS.ByteString -> Bool+    constTimeEq x y+      | BS.length x /= BS.length y+      = False++      | otherwise+      = foldl' (.|.) 0 (BS.zipWith xor x y) == 0
+ src/Happstack/Server/Compression.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}+-- | Filter for compressing the 'Response' body.+module Happstack.Server.Compression+    ( compressedResponseFilter+    , compressedResponseFilter'+    , compressWithFilter+    , gzipFilter+    , deflateFilter+    , identityFilter+    , starFilter+    , standardEncodingHandlers+    ) where++import Happstack.Server.Internal.Compression ( compressedResponseFilter+                                             , compressedResponseFilter'+                                             , compressWithFilter+                                             , gzipFilter+                                             , deflateFilter+                                             , identityFilter+                                             , starFilter+                                             , standardEncodingHandlers+                                             )+
src/Happstack/Server/Cookie.hs view
@@ -1,138 +1,48 @@-{-# LANGUAGE DeriveDataTypeable #-}---- http://tools.ietf.org/html/rfc2109+{-# LANGUAGE FlexibleContexts #-}+-- | Functions for creating, adding, and expiring cookies. To lookup cookie values see "Happstack.Server.RqData". module Happstack.Server.Cookie     ( Cookie(..)+    , CookieLife(..)+    , SameSite(..)     , mkCookie-    , mkCookieHeader-    , getCookies-    , getCookie-    , getCookies'-    , getCookie'-    , parseCookies-    , cookiesParser+    , addCookie+    , addCookies+    , expireCookie     )     where -import qualified Data.ByteString.Char8 as C-import Data.Either-import Data.Char-import Data.List-import Data.Generics-import Happstack.Util.Common (Seconds)-import Text.ParserCombinators.Parsec hiding (token)--data Cookie = Cookie-    { cookieVersion :: String-    , cookiePath    :: String-    , cookieDomain  :: String-    , cookieName    :: String-    , cookieValue   :: String-    } deriving(Show,Eq,Read,Typeable,Data)---- | Creates a cookie with a default version of 1 and path of "/"-mkCookie :: String -> String -> Cookie-mkCookie key val = Cookie "1" "/" "" key val---- | Set a Cookie in the Result.--- The values are escaped as per RFC 2109, but some browsers may--- have buggy support for cookies containing e.g. @\'\"\'@ or @\' \'@.-mkCookieHeader :: Seconds -> Cookie -> String-mkCookieHeader sec cookie =-    let l = [("Domain=",s cookieDomain)-            ,("Max-Age=",if sec < 0 then "" else show sec)-            ,("Path=", cookiePath cookie)-            ,("Version=", s cookieVersion)]-        s f | f cookie == "" = ""-        s f   = '\"' : concatMap e (f cookie) ++ "\""-        e c | fctl c || c == '"' = ['\\',c]-            | otherwise          = [c]-    in concat $ intersperse ";" ((cookieName cookie++"="++s cookieValue):[ (k++v) | (k,v) <- l, "" /= v ])--fctl :: Char -> Bool-fctl ch = ch == chr 127 || ch <= chr 31---- | Not an supported api.  Takes a cookie header and returns--- either a String error message or an array of parsed cookies-parseCookies :: String -> Either String [Cookie]-parseCookies str = either (Left . show) Right $ parse cookiesParser str str---- | not a supported api.  A parser for RFC 2109 cookies-cookiesParser :: GenParser Char st [Cookie]-cookiesParser = cookies-    where -- Parsers based on RFC 2109-          cookies = do-            ws-            ver<-option "" $ try (cookie_version >>= (\x -> cookieSep >> return x))-            cookieList<-(cookie_value ver) `sepBy1` try cookieSep-            ws-            eof-            return cookieList-          cookie_value ver = do-            name<-attr-            cookieEq-            val<-value-            path<-option "" $ try (cookieSep >> cookie_path)-            domain<-option "" $ try (cookieSep >> cookie_domain)-            return $ Cookie ver path domain (low name) val-          cookie_version = cookie_special "$Version"-          cookie_path = cookie_special "$Path"-          cookie_domain = cookie_special "$Domain"-          cookie_special s = do-            string s-            cookieEq-            value-          cookieSep = ws >> oneOf ",;" >> ws-          cookieEq = ws >> char '=' >> ws-          ws = spaces-          attr          = token-          value         = word-          word          = try (quoted_string) <|> incomp_token--          -- Parsers based on RFC 2068-          token         = many1 $ oneOf ((chars \\ ctl) \\ tspecials)-          quoted_string = do-            char '"'-            r <-many (oneOf qdtext)-            char '"'-            return r--          -- Custom parser, incompatible with RFC 2068, but very  forgiving ;)-          incomp_token  = many1 $ oneOf ((chars \\ ctl) \\ " \t\";")--          -- Primitives from RFC 2068-          tspecials     = "()<>@,;:\\\"/[]?={} \t"-          ctl           = map chr (127:[0..31])-          chars         = map chr [0..127]-          octet         = map chr [0..255]-          text          = octet \\ ctl-          qdtext        = text \\ "\""---- | Get all cookies from the HTTP request. The cookies are ordered per RFC from--- the most specific to the least specific. Multiple cookies with the same--- name are allowed to exist.-getCookies :: Monad m => C.ByteString -> m [Cookie]-getCookies h = getCookies' h >>=  either (fail. ("Cookie parsing failed!"++)) return---- | Get the most specific cookie with the given name. Fails if there is no such--- cookie or if the browser did not escape cookies in a proper fashion.--- Browser support for escaping cookies properly is very diverse.-getCookie :: Monad m => String -> C.ByteString -> m Cookie-getCookie s h = getCookie' s h >>= either (const $ fail ("getCookie: " ++ show s)) return+import Control.Monad.Trans              (MonadIO(..))+import Happstack.Server.Internal.Monads (FilterMonad, composeFilter)+import Happstack.Server.Internal.Cookie (Cookie(..), CookieLife(..), SameSite(..), calcLife, mkCookie, mkCookieHeader)+import Happstack.Server.Types           (Response, addHeader) -getCookies' :: Monad m => C.ByteString -> m (Either String [Cookie])-getCookies' header | C.null header = return $ Right []-                   | otherwise     = return $ parseCookies (C.unpack header)+-- | Add the 'Cookie' to 'Response'.+--+-- example+--+-- > main = simpleHTTP nullConf $+-- >   do addCookie Session (mkCookie "name" "value")+-- >      ok $ "You now have a session cookie."+--+-- see also: 'addCookies'+addCookie :: (MonadIO m, FilterMonad Response m) => CookieLife -> Cookie -> m ()+addCookie life cookie =+    do l <- liftIO $ calcLife life+       (addHeaderM "Set-Cookie") $ mkCookieHeader l cookie+    where+      addHeaderM a v = composeFilter $ \res-> addHeader a v res -getCookie' :: Monad m => String -> C.ByteString -> m (Either String Cookie)-getCookie' s h = do-    cs <- getCookies' h-    return $ do -- Either-       cooks <- cs-       case filter (\x->(==)  (low s)  (cookieName x) ) cooks of-            [] -> fail "No cookie found"-            f -> return $ head f+-- | Add the list 'Cookie' to the 'Response'.+--+-- see also: 'addCookie'+addCookies :: (MonadIO m, FilterMonad Response m) => [(CookieLife, Cookie)] -> m ()+addCookies = mapM_ (uncurry addCookie) -low :: String -> String-low = map toLower+-- | Expire the named cookie immediately and set the cookie value to @\"\"@+--+-- > main = simpleHTTP nullConf $+-- >   do expireCookie "name"+-- >      ok $ "The cookie has been expired." +expireCookie :: (MonadIO m, FilterMonad Response m) => String -> m ()+expireCookie name = addCookie Expired (mkCookie name "")
+ src/Happstack/Server/Error.hs view
@@ -0,0 +1,57 @@+-- | Some useful functions if you want to wrap the 'ServerPartT' monad transformer around the 'ErrorT' monad transformer. e.g., @'ServerPartT' ('ErrorT' e m) a@. This allows you to use 'throwError' and 'catchError' inside your monad.  +module Happstack.Server.Error where++import Control.Monad.Trans.Except       (ExceptT, runExceptT)+import Happstack.Server.Monads          (ServerPartT)+import Happstack.Server.Internal.Monads (WebT, UnWebT, withRequest, mkWebT, runServerPartT, ununWebT)+import Happstack.Server.Response        (ok, toResponse)+import Happstack.Server.Types           (Request, Response)++--------------------------------------------------------------+-- Error Handling+--------------------------------------------------------------++-- | Flatten @'ServerPartT' ('ErrorT' e m) a@ into a @'ServerPartT' m+-- a@ so that it can be use with 'simpleHTTP'.  Used with+-- 'mapServerPartT'', e.g.,+--+-- > simpleHTTP conf $ mapServerPartT' (spUnWrapErrorT simpleErrorHandler)  $ myPart `catchError` errorPart+--+-- Note that in this example, @simpleErrorHandler@ will only be run if @errorPart@ throws an error. You can replace @simpleErrorHandler@ with your own custom error handler.+--+-- see also: 'simpleErrorHandler'+spUnwrapErrorT:: Monad m => (e -> ServerPartT m a)+              -> Request+              -> UnWebT (ExceptT e m) a+              -> UnWebT m a+spUnwrapErrorT handler rq = \x -> do+    err <- runExceptT x+    case err of+        Left e -> ununWebT $ runServerPartT (handler e) rq+        Right a -> return a++-- | A simple error handler which can be used with 'spUnwrapErrorT'.+-- +-- It returns the error message as a plain text message to the+-- browser. More sophisticated behaviour can be achieved by calling+-- your own custom error handler instead.+--+-- see also: 'spUnwrapErrorT'+simpleErrorHandler :: (Monad m) => String -> ServerPartT m Response+simpleErrorHandler err = ok $ toResponse $ ("An error occured: " ++ err)++-- | This 'ServerPart' modifier enables the use of 'throwError' and+-- 'catchError' inside the 'WebT' actions, by adding the 'ErrorT'+-- monad transformer to the stack.+--+-- You can wrap the complete second argument to 'simpleHTTP' in this+-- function.+--+-- DEPRECATED: use 'spUnwrapErrorT' instead.+errorHandlerSP :: (Monad m) => (Request -> e -> WebT m a) -> ServerPartT (ExceptT e m) a -> ServerPartT m a+errorHandlerSP handler sps = withRequest $ \req -> mkWebT $ do+                        eer <- runExceptT $ ununWebT $ runServerPartT sps req+                        case eer of+                                Left err -> ununWebT (handler req err)+                                Right res -> return res+{-# DEPRECATED errorHandlerSP "Use spUnwrapErrorT" #-}
+ src/Happstack/Server/FileServe.hs view
@@ -0,0 +1,20 @@+-- | functions for serving static files from the disk+module Happstack.Server.FileServe +    ( -- * Serving Functions +      Browsing(..)+    , serveDirectory+    , serveFile+    , serveFileFrom+     -- * Content-Type \/ Mime-Type+     , MimeMap+     , mimeTypes+     , asContentType+     , guessContentTypeM+     -- * Index Files+    , defaultIxFiles+    -- * Deprecated+    , fileServe+    )+    where++import Happstack.Server.FileServe.BuildingBlocks
+ src/Happstack/Server/FileServe/BuildingBlocks.hs view
@@ -0,0 +1,716 @@+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, ScopedTypeVariables, Rank2Types #-}+-- | Build your own file serving functions+--+-- If the functions in "Happstack.Server.FileServe" do not quite do+-- you want you can roll your own by reusing pieces from this module.+--+-- You will likely want to start by copying the source for a function+-- like, 'serveDirectory' and then modifying it to suit your needs.+--+module Happstack.Server.FileServe.BuildingBlocks+    (+     -- * High-Level+     -- ** Serving files from a directory+     fileServe,+     fileServe',+     fileServeLazy,+     fileServeStrict,+     Browsing(..),+     serveDirectory,+     serveDirectory',+     -- ** Serving a single file+     serveFile,+     serveFileFrom,+     serveFileUsing,+     -- * Low-Level+     sendFileResponse,+     lazyByteStringResponse,+     strictByteStringResponse,+     filePathSendFile,+     filePathLazy,+     filePathStrict,+     -- * Content-Type \/ Mime-Type+     MimeMap,+     mimeTypes,+     asContentType,+     guessContentType,+     guessContentTypeM,+     -- * Directory Browsing+     EntryKind(..),+     browseIndex,+     renderDirectoryContents,+     renderDirectoryContentsTable,+     -- * Other+     blockDotFiles,+     defaultIxFiles,+     combineSafe,+     isSafePath,+     tryIndex,+     doIndex,+     doIndex',+     doIndexLazy,+     doIndexStrict,+     fileNotFound,+     isDot+    ) where++import Control.Exception.Extensible as E (IOException, bracket, catch)+import Control.Monad                (MonadPlus(mzero), msum)+import Control.Monad.Trans          (MonadIO(liftIO))+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Char8 as S+import Data.Char                    (toLower)+import Data.Data                    (Data)+import Data.List                    (sort)+import Data.Maybe                   (fromMaybe)+import           Data.Map           (Map)+import qualified Data.Map           as Map+import Data.Time                    (UTCTime, formatTime, defaultTimeLocale)+import Filesystem.Path.CurrentOS    (commonPrefix, encodeString, decodeString, collapse, append)+import Happstack.Server.Monads      (ServerMonad(askRq), FilterMonad, WebMonad)+import Happstack.Server.Response    (ToMessage(toResponse), ifModifiedSince, forbidden, ok, seeOther)+import Happstack.Server.Types       (Length(ContentLength), Request(rqPaths, rqUri), Response(SendFile), RsFlags(rsfLength), nullRsFlags, result, resultBS, setHeader)+import System.Directory             (doesDirectoryExist, doesFileExist, getDirectoryContents, getModificationTime)+import System.FilePath              ((</>), addTrailingPathSeparator, hasDrive, isPathSeparator, joinPath, takeExtension, isValid)+import System.IO                    (IOMode(ReadMode), hFileSize, hClose, openBinaryFile, withBinaryFile)+import System.Log.Logger            (Priority(DEBUG), logM)+import           Text.Blaze.Html             ((!))+import qualified Text.Blaze.Html5            as H+import qualified Text.Blaze.Html5.Attributes as A++-- * Mime-Type / Content-Type++-- |a 'Map' from file extensions to content-types+--+-- example:+--+-- > myMimeMap :: MimeMap+-- > myMimeMap = Map.fromList [("gz","application/x-gzip"), ... ]+--+-- see also: 'mimeTypes'+type MimeMap = Map String String++-- | try to guess the content-type of a file based on its extension+--+-- see also: 'guessContentTypeM'+guessContentType :: MimeMap -> FilePath -> Maybe String+guessContentType mimeMap filepath =+    case getExt filepath of+      "" -> Nothing+      ext -> Map.lookup (map toLower ext) mimeMap -- FIXME? @foldCase@ would be more proper than @map toLower@ but would add a dependency. But are those edge cases ever going to be relevant here?++-- | try to guess the content-type of a file based on its extension+--+-- defaults to "application/octet-stream" if no match was found.+--+-- Useful as an argument to 'serveFile'+--+-- see also: 'guessContentType', 'serveFile'+guessContentTypeM :: (Monad m) => MimeMap -> (FilePath -> m String)+guessContentTypeM mimeMap filePath = return $ fromMaybe "application/octet-stream" $ guessContentType mimeMap filePath++-- | returns a specific content type, completely ignoring the 'FilePath' argument.+--+-- Use this with 'serveFile' if you want to explicitly specify the+-- content-type.+--+-- see also: 'guessContentTypeM', 'serveFile'+asContentType :: (Monad m) =>+                 String  -- ^ the content-type to return+              -> (FilePath -> m String)+asContentType = const . return++-- | a list of common index files. Specifically: @index.html@, @index.xml@, @index.gif@+--+-- Typically used as an argumebnt to 'serveDiretory'.+defaultIxFiles :: [FilePath]+defaultIxFiles= ["index.html","index.xml","index.gif"]++-- | return a simple "File not found 404 page."+fileNotFound :: (Monad m, FilterMonad Response m) => FilePath -> m Response+fileNotFound fp = return $ result 404 $ "File not found " ++ fp++-- | Similar to 'takeExtension' but does not include the extension separator char+--+-- NOTE: this does not perform case folding. So @example.jpg@ will return @.jpg@ and @example.JPG@ will return @.JPG@.+getExt :: FilePath -> String+getExt fp = drop 1 $ takeExtension fp++-- | Prevents files of the form '.foo' or 'bar/.foo' from being served+blockDotFiles :: (Request -> IO Response) -> Request -> IO Response+blockDotFiles fn rq+    | isDot (joinPath (rqPaths rq)) = return $ result 403 "Dot files not allowed."+    | otherwise = fn rq++-- | Returns True if the given String either starts with a . or is of the form+-- "foo/.bar", e.g. the typical *nix convention for hidden files.+isDot :: String -> Bool+isDot = isD . reverse+    where+    isD ('.':'/':_) = True+    isD ['.']       = True+    --isD ('/':_)     = False+    isD (_:cs)      = isD cs+    isD []          = False++-- * Low-level functions for generating a Response++-- | Use sendFile to send the contents of a Handle+sendFileResponse :: String  -- ^ content-type string+                 -> FilePath  -- ^ file path for content to send+                 -> Maybe (UTCTime, Request) -- ^ mod-time for the handle (MUST NOT be later than server's time of message origination), incoming request (used to check for if-modified-since header)+                 -> Integer -- ^ offset into Handle+                 -> Integer -- ^ number of bytes to send+                 -> Response+sendFileResponse ct filePath mModTime offset count =+    let res = ((setHeader "Content-Type" ct) $+               (SendFile 200 Map.empty (nullRsFlags { rsfLength = ContentLength }) Nothing filePath offset count)+              )+    in case mModTime of+         Nothing -> res+         (Just (modTime, request)) -> ifModifiedSince modTime request res++-- | Send the contents of a Lazy ByteString+--+lazyByteStringResponse :: String   -- ^ content-type string (e.g. @\"text/plain; charset=utf-8\"@)+                       -> L.ByteString   -- ^ lazy bytestring content to send+                       -> Maybe (UTCTime, Request) -- ^ mod-time for the bytestring, incoming request (used to check for if-modified-since header)+                       -> Integer -- ^ offset into the bytestring+                       -> Integer -- ^ number of bytes to send (offset + count must be less than or equal to the length of the bytestring)+                       -> Response+lazyByteStringResponse ct body mModTime offset count =+    let res = ((setHeader "Content-Type" ct) $+               resultBS 200 (L.take (fromInteger count) $ (L.drop (fromInteger offset))  body)+              )+    in case mModTime of+         Nothing -> res+         (Just (modTime, request)) -> ifModifiedSince modTime request res++-- | Send the contents of a Lazy ByteString+strictByteStringResponse :: String   -- ^ content-type string (e.g. @\"text/plain; charset=utf-8\"@)+                         -> S.ByteString   -- ^ lazy bytestring content to send+                         -> Maybe (UTCTime, Request) -- ^ mod-time for the bytestring, incoming request (used to check for if-modified-since header)+                         -> Integer -- ^ offset into the bytestring+                         -> Integer -- ^ number of bytes to send (offset + count must be less than or equal to the length of the bytestring)+                         -> Response+strictByteStringResponse ct body mModTime offset count =+    let res = ((setHeader "Content-Type" ct) $+               resultBS 200 (L.fromChunks [S.take (fromInteger count) $ S.drop (fromInteger offset) body])+              )+    in case mModTime of+         Nothing -> res+         (Just (modTime, request)) -> ifModifiedSince modTime request res++-- | Send the specified file with the specified mime-type using sendFile()+--+-- NOTE: assumes file exists and is readable by the server. See 'serveFileUsing'.+--+-- WARNING: No security checks are performed.+filePathSendFile :: (ServerMonad m, MonadIO m)+                 => String   -- ^ content-type string+                 -> FilePath -- ^ path to file on disk+                 -> m Response+filePathSendFile contentType fp =+    do count   <- liftIO $ withBinaryFile fp ReadMode hFileSize -- garbage collection should close this+       modtime <- liftIO $ getModificationTime fp+       rq      <- askRq+       return $ sendFileResponse contentType fp (Just (modtime, rq)) 0 count++-- | Send the specified file with the specified mime-type using lazy ByteStrings+--+-- NOTE: assumes file exists and is readable by the server. See 'serveFileUsing'.+--+-- WARNING: No security checks are performed.+filePathLazy :: (ServerMonad m, MonadIO m)+                 => String   -- ^ content-type string+                 -> FilePath -- ^ path to file on disk+                 -> m Response+filePathLazy contentType fp =+    do handle   <- liftIO $ openBinaryFile fp ReadMode -- garbage collection should close this+       contents <- liftIO $ L.hGetContents handle+       modtime  <- liftIO $ getModificationTime fp+       count    <- liftIO $ hFileSize handle+       rq       <- askRq+       return $ lazyByteStringResponse contentType contents (Just (modtime, rq)) 0 count++-- | Send the specified file with the specified mime-type using strict ByteStrings+--+-- NOTE: assumes file exists and is readable by the server. See 'serveFileUsing'.+--+-- WARNING: No security checks are performed.+filePathStrict :: (ServerMonad m, MonadIO m)+                 => String   -- ^ content-type string+                 -> FilePath -- ^ path to file on disk+                 -> m Response+filePathStrict contentType fp =+    do contents <- liftIO $ S.readFile fp+       modtime  <- liftIO $ getModificationTime fp+       count    <- liftIO $ withBinaryFile fp ReadMode hFileSize+       rq       <- askRq+       return $ strictByteStringResponse contentType contents (Just (modtime, rq)) 0 count++-- * High-level functions for serving files+++-- ** Serve a single file++-- | Serve a single, specified file. The name of the file being served is specified explicity. It is not derived automatically from the 'Request' url.+--+-- example 1:+--+--  Serve using sendfile() and the specified content-type+--+-- > serveFileUsing filePathSendFile (asContentType "image/jpeg") "/srv/data/image.jpg"+--+--+-- example 2:+--+--  Serve using a lazy ByteString and the guess the content-type from the extension+--+-- > serveFileUsing filePathLazy (guessContentTypeM mimeTypes) "/srv/data/image.jpg"+--+-- WARNING: No security checks are performed.+serveFileUsing :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m)+               => (String -> FilePath -> m Response) -- ^ typically 'filePathSendFile', 'filePathLazy', or 'filePathStrict'+               -> (FilePath -> m String)  -- ^ function for determining content-type of file. Typically 'asContentType' or 'guessContentTypeM'+               -> FilePath -- ^ path to the file to serve+               -> m Response+serveFileUsing serveFn mimeFn fp =+    do fe <- liftIO $ doesFileExist fp+       if fe+          then do mt <- mimeFn fp+                  serveFn mt fp+          else mzero++-- | Serve a single, specified file. The name of the file being served is specified explicity. It is not derived automatically from the 'Request' url.+--+-- example 1:+--+--  Serve as a specific content-type:+--+-- > serveFile (asContentType "image/jpeg") "/srv/data/image.jpg"+--+--+-- example 2:+--+--  Serve guessing the content-type from the extension:+--+-- > serveFile (guessContentTypeM mimeTypes) "/srv/data/image.jpg"+--+-- If the specified path does not exist or is not a file, this function will return 'mzero'.+--+-- WARNING: No security checks are performed.+--+-- NOTE: alias for 'serveFileUsing' 'filePathSendFile'+serveFile :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) =>+             (FilePath -> m String)   -- ^ function for determining content-type of file. Typically 'asContentType' or 'guessContentTypeM'+          -> FilePath                 -- ^ path to the file to serve+          -> m Response+serveFile = serveFileUsing filePathSendFile++-- | Like 'serveFile', but uses 'combineSafe' to prevent directory+-- traversal attacks when the path to the file is supplied by the user.+serveFileFrom :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) =>+                 FilePath                 -- ^ directory wherein served files must be contained+              -> (FilePath -> m String)   -- ^ function for determining content-type of file. Typically 'asContentType' or 'guessContentTypeM'+              -> FilePath                 -- ^ path to the file to serve+              -> m Response+serveFileFrom root mimeFn fp =+    maybe no yes $ combineSafe root fp+  where+    no  = forbidden $ toResponse "Directory traversal forbidden"+    yes = serveFile mimeFn++-- ** Serve files from a directory++-- | Serve files from a directory and its subdirectories (parameterizable version)+--+-- Parameterize this function to create functions like, 'fileServe', 'fileServeLazy', and 'fileServeStrict'+--+-- You supply:+--+--  1. a low-level function which takes a content-type and 'FilePath' and generates a Response+--+--  2. a function which determines the content-type from the 'FilePath'+--+--  3. a list of all the default index files+--+-- NOTE: unlike fileServe, there are no index files by default. See 'defaultIxFiles'.+fileServe' :: ( WebMonad Response m+              , ServerMonad m+              , FilterMonad Response m+              , MonadIO m+              , MonadPlus m+              )+           => (String -> FilePath -> m Response) -- ^ function which takes a content-type and filepath and generates a response (typically 'filePathSendFile', 'filePathLazy', or 'filePathStrict')+           -> (FilePath -> m String) -- ^ function which returns the mime-type for FilePath+--           -> [FilePath]         -- ^ index file names, in case the requested path is a directory+           -> (FilePath -> m Response)+           -> FilePath           -- ^ file/directory to serve+           -> m Response+fileServe' serveFn mimeFn indexFn localPath = do+    rq <- askRq+    if (not $ isSafePath (rqPaths rq))+       then do liftIO $ logM "Happstack.Server.FileServe" DEBUG ("fileServe: unsafe filepath " ++ show (rqPaths rq))+               mzero+       else do let fp = joinPath (localPath : rqPaths rq)+               fe <- liftIO $ doesFileExist fp+               de <- liftIO $ doesDirectoryExist fp+               let status | de   = "DIR"+                          | fe   = "file"+                          | True = "NOT FOUND"+               liftIO $ logM "Happstack.Server.FileServe" DEBUG ("fileServe: "++show fp++" \t"++status)+               if de+                  then if last (rqUri rq) == '/'+                          then indexFn fp+                          else do let path' = addTrailingPathSeparator (rqUri rq)+                                  seeOther path' (toResponse path')+                  else if fe+                          then serveFileUsing serveFn mimeFn fp+                          else mzero++-- | Combine two 'FilePath's, ensuring that the resulting path leads to+-- a file within the first 'FilePath'.+--+-- >>> combineSafe "/var/uploads/" "etc/passwd"+-- Just "/var/uploads/etc/passwd"+-- >>> combineSafe "/var/uploads/" "/etc/passwd"+-- Nothing+-- >>> combineSafe "/var/uploads/" "../../etc/passwd"+-- Nothing+-- >>> combineSafe "/var/uploads/" "../uploads/home/../etc/passwd"+-- Just "/var/uploads/etc/passwd"+combineSafe :: FilePath -> FilePath -> Maybe FilePath+combineSafe root path =+    if commonPrefix [root', joined] == root'+      then Just $ encodeString joined+      else Nothing+  where+    root'  = decodeString root+    path'  = decodeString path+    joined = collapse $ append root' path'++isSafePath :: [FilePath] -> Bool+isSafePath [] = True+isSafePath (s:ss) =+     isValid s+  && (all (not . isPathSeparator) s)+  && not (hasDrive s)+  && not (isParent s)+  && isSafePath ss++-- note: could be different on other OSs+isParent :: FilePath -> Bool+isParent ".." = True+isParent _    = False++-- | Serve files from a directory and its subdirectories using 'sendFile'.+--+-- Usage:+--+-- > fileServe ["index.html"] "path/to/files/on/disk"+--+--  'fileServe' does not support directory browsing. See 'serveDirectory'+--+-- DEPRECATED: use 'serveDirectory' instead.+--+-- Note:+--+--  The list of index files @[\"index.html\"]@ is only used to determine what file to show if the user requests a directory. You *do not* need to explicitly list all the files you want to serve.+--+fileServe :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) =>+             [FilePath]         -- ^ index file names, in case the requested path is a directory+          -> FilePath           -- ^ file/directory to serve+          -> m Response+fileServe ixFiles localPath =+    fileServe' serveFn mimeFn indexFn localPath+        where+          serveFn    = filePathSendFile+          mimeFn     = guessContentTypeM mimeTypes+          indexFiles = (ixFiles ++ defaultIxFiles)+          indexFn    = doIndex' filePathSendFile mimeFn indexFiles+--          indexFn    = browseIndex filePathSendFile mimeFn indexFiles+{-# DEPRECATED fileServe "use serveDirectory instead." #-}++-- | Serve files from a directory and its subdirectories (lazy ByteString version).+--+-- WARNING: May leak file handles. You should probably use 'fileServe' instead.+fileServeLazy :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) =>+             [FilePath]         -- ^ index file names, in case the requested path is a directory+          -> FilePath           -- ^ file/directory to serve+          -> m Response+fileServeLazy ixFiles localPath =+    fileServe' serveFn mimeFn indexFn localPath+        where+          serveFn    = filePathLazy+          mimeFn     = guessContentTypeM mimeTypes+          indexFiles = (ixFiles ++ defaultIxFiles)+          indexFn    = doIndex' filePathSendFile mimeFn indexFiles++-- | Serve files from a directory and its subdirectories (strict ByteString version).+--+-- WARNING: the entire file will be read into RAM before being served. You should probably use 'fileServe' instead.+fileServeStrict :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) =>+             [FilePath]         -- ^ index file names, in case the next argument is a directory+          -> FilePath           -- ^ file/directory to serve+          -> m Response+fileServeStrict ixFiles localPath =+    fileServe' serveFn mimeFn indexFn localPath+        where+          serveFn    = filePathStrict+          mimeFn     = guessContentTypeM mimeTypes+          indexFiles = (ixFiles ++ defaultIxFiles)+          indexFn    = doIndex' filePathSendFile mimeFn indexFiles++-- * Index++-- | attempt to serve index files+doIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m)+        => [FilePath] -- ^ list of possible index files (e.g., @index.html@)+        -> MimeMap    -- ^ see also 'mimeTypes'+        -> FilePath   -- ^ directory on disk to search for index files+        -> m Response+doIndex ixFiles mimeMap localPath = doIndex' filePathSendFile (guessContentTypeM mimeMap) ixFiles localPath++doIndexLazy :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m)+        => [String]+        -> MimeMap+        -> FilePath+        -> m Response+doIndexLazy ixFiles mimeMap localPath = doIndex' filePathLazy (guessContentTypeM mimeMap) ixFiles localPath++doIndexStrict :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m)+        => [String]+        -> MimeMap+        -> FilePath+        -> m Response+doIndexStrict ixFiles mimeMap localPath = doIndex' filePathStrict (guessContentTypeM mimeMap) ixFiles localPath++doIndex' :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m)+        => (String -> FilePath -> m Response)+        -> (FilePath -> m String)+        -> [String]+        -> FilePath+        -> m Response+doIndex' serveFn mimeFn ixFiles fp =+    msum [ tryIndex serveFn mimeFn ixFiles fp+         , forbidden $ toResponse "Directory index forbidden"+         ]++-- | try to find an index file, calls mzero on failure+tryIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m)+        => (String -> FilePath -> m Response) -- ^ usually 'filePathSendFile'+        -> (FilePath -> m String)             -- ^ function to calculate mime type, usually 'guessContentTypeM'+        -> [String]                           -- ^ list of index files. See also 'defaultIxFiles'+        -> FilePath                           -- ^ directory to search in+        -> m Response+tryIndex _serveFn _mime  []          _fp = mzero+tryIndex  serveFn mimeFn (index:rest) fp =+    do let path = fp </> index+       fe <- liftIO $ doesFileExist path+       if fe+          then serveFileUsing serveFn mimeFn path+          else tryIndex serveFn mimeFn rest fp++-- * Directory Browsing++browseIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m, ToMessage b) =>+                (FilePath -> [FilePath] -> m b)+             -> (String -> FilePath -> m Response)+             -> (FilePath -> m String)+             -> [String]+             -> FilePath+             -> m Response+browseIndex renderFn _serveFn _mimeFn _ixFiles localPath =+    do c       <- liftIO $ getDirectoryContents localPath+       listing <- renderFn localPath $ filter (/= ".") (sort c)+       ok $ toResponse $ listing++data EntryKind = File | Directory | UnknownKind deriving (Eq, Ord, Read, Show, Data, Enum)++-- | a function to generate an HTML page showing the contents of a directory on the disk+--+-- see also: 'browseIndex', 'renderDirectoryContentsTable'+renderDirectoryContents :: (MonadIO m) =>+                           FilePath    -- ^ path to directory on disk+                        -> [FilePath]  -- ^ list of entries in that path+                        -> m H.Html+renderDirectoryContents localPath fps =+    do fps' <- liftIO $ mapM (getMetaData localPath) fps+       return $ H.html $ do+         H.head $ do+           H.title $ H.toHtml "Directory Listing"+           H.meta  ! A.httpEquiv (H.toValue "Content-Type") ! A.content (H.toValue "text/html;charset=utf-8")+           H.style $ H.toHtml $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"+                                        , "table, th, td { border: 1px solid #353948; }"+                                        , "td.size { text-align: right; font-size: 0.7em; width: 50px }"+                                        , "td.date { text-align: right; font-size: 0.7em; width: 130px }"+                                        , "td { padding-right: 1em; padding-left: 1em; }"+                                        , "th.first { background-color: white; width: 24px }"+                                        , "td.first { padding-right: 0; padding-left: 0; text-align: center }"+                                        , "tr { background-color: white; }"+                                        , "tr.alt { background-color: #A3B5BA}"+                                        , "th { background-color: #3C4569; color: white; font-size: 1em; }"+                                        , "h1 { width: 760px; margin: 1em auto; font-size: 1em }"+                                        , "img { width: 20px }"+                                        , "a { text-decoration: none }"+                                        ]+         H.body $ do+           H.h1 $ H.toHtml "Directory Listing"+           renderDirectoryContentsTable fps'++-- | a function to generate an HTML table showing the contents of a directory on the disk+--+-- This function generates most of the content of the+-- 'renderDirectoryContents' page. If you want to style the page+-- differently, or add google analytics code, etc, you can just create+-- a new page template to wrap around this HTML.+--+-- see also: 'getMetaData', 'renderDirectoryContents'+renderDirectoryContentsTable :: [(FilePath, Maybe UTCTime, Maybe Integer, EntryKind)] -- ^ list of files+meta data, see 'getMetaData'+                             -> H.Html+renderDirectoryContentsTable fps =+           H.table $ do H.thead $ do H.th $ H.toHtml ""+                                     H.th $ H.toHtml "Name"+                                     H.th $ H.toHtml "Last modified"+                                     H.th $ H.toHtml "Size"+                        H.tbody $ mapM_ mkRow (zip fps $ cycle [False, True])+    where+      mkRow :: ((FilePath, Maybe UTCTime, Maybe Integer, EntryKind), Bool) -> H.Html+      mkRow ((fp, modTime, count, kind), alt) =+          (if alt then (! A.class_ (H.toValue "alt")) else id) $+          H.tr $ do+                   H.td (mkKind kind)+                   H.td (H.a ! A.href (H.toValue fp)  $ H.toHtml fp)+                   H.td ! A.class_ (H.toValue "date") $ (H.toHtml $ maybe "-" (formatTime defaultTimeLocale "%d-%b-%Y %X %Z") modTime)+                   (maybe id (\c -> (! A.title (H.toValue (show c)))) count)  (H.td ! A.class_ (H.toValue "size") $ (H.toHtml $ maybe "-" prettyShow count))+      mkKind :: EntryKind -> H.Html+      mkKind File        = return ()+      mkKind Directory   = H.toHtml "➦"+      mkKind UnknownKind = return ()+      prettyShow x+        | x > 1024 = prettyShowK $ x `div` 1024+        | otherwise = addCommas "B" x+      prettyShowK x+        | x > 1024 = prettyShowM $ x `div` 1024+        | otherwise = addCommas "KB" x+      prettyShowM x+        | x > 1024 = prettyShowG $ x `div` 1024+        | otherwise = addCommas "MB" x+      prettyShowG x = addCommas "GB" x+      addCommas s = (++ (' ' : s)) . reverse . addCommas' . reverse . show+      addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)+      addCommas' x = x+++-- | look up the meta data associated with a file+getMetaData :: FilePath -- ^ path to directory on disk containing the entry+            -> FilePath -- ^ entry in that directory+            -> IO (FilePath, Maybe UTCTime, Maybe Integer, EntryKind)+getMetaData localPath fp =+     do let localFp = localPath </> fp+        modTime <- (Just <$> getModificationTime localFp) `E.catch`+                   (\(_ :: IOException) -> return Nothing)+        count <- do de <- doesDirectoryExist localFp+                    if de+                      then do return Nothing+                      else do bracket (openBinaryFile localFp ReadMode) hClose (fmap Just . hFileSize)+                                          `E.catch` (\(_e :: IOException) -> return Nothing)+        kind <- do fe <- doesFileExist localFp+                   if fe+                      then return File+                      else do de <- doesDirectoryExist localFp+                              if de+                                 then return Directory+                                 else return UnknownKind+        return (if kind == Directory then (fp ++ "/") else fp, modTime, count, kind)++-- | see 'serveDirectory'+data Browsing+    = EnableBrowsing | DisableBrowsing+      deriving (Eq, Enum, Ord, Read, Show, Data)++-- | Serve files and directories from a directory and its subdirectories using 'sendFile'.+--+-- Usage:+--+-- > serveDirectory EnableBrowsing ["index.html"] "path/to/files/on/disk"+--+-- If the requested path does not match a file or directory on the+-- disk, then 'serveDirectory' calls 'mzero'.+--+-- If the requested path is a file then the file is served normally.+--+-- If the requested path is a directory, then the result depends on+-- what the first two arguments to the function are.+--+-- The first argument controls whether directory browsing is+-- enabled.+--+-- The second argument is a list of index files (such as+-- index.html).+--+-- When a directory is requested, 'serveDirectory' will first try to+-- find one of the index files (in the order they are listed). If that+-- fails, it will show a directory listing if 'EnableBrowsing' is set,+-- otherwise it will return @forbidden \"Directory index forbidden\"@.+--+-- Here is an explicit list of all the possible outcomes when the+-- argument is a (valid) directory:+--+-- [@'DisableBrowsing', empty index file list@]+--+--  This will always return, forbidden \"Directory index forbidden\"+--+-- [@'DisableBrowsing', non-empty index file list@]+--+-- 1. If an index file is found it will be shown.+--+-- 2. Otherwise returns, forbidden \"Directory index forbidden\"+--+-- [@'EnableBrowsing', empty index file list@]+--+-- Always shows a directory index.+--+-- [@'EnableBrowsing', non-empty index file list@]+--+-- 1. If an index file is found it will be shown+--+-- 2. Otherwise shows a directory index+--+-- see also: 'defaultIxFiles', 'serveFile'+serveDirectory :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) =>+                  Browsing    -- ^ allow directory browsing+               -> [FilePath]  -- ^ index file names, in case the requested path is a directory+               -> FilePath    -- ^ file/directory to serve+               -> m Response+serveDirectory browsing ixFiles localPath =+    serveDirectory' browsing ixFiles mimeFn localPath+        where+          mimeFn  = guessContentTypeM mimeTypes+++-- | like 'serveDirectory' but with custom mimeTypes+serveDirectory' :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m)+                => Browsing    -- ^ allow directory browsing+                -> [FilePath]  -- ^ index file names, in case the requested path is a directory+                -> (FilePath -> m String) -- ^ function which returns the mime-type for FilePath+                -> FilePath    -- ^ file/directory to serve+                -> m Response+serveDirectory' browsing ixFiles mimeFn localPath =+    fileServe' serveFn mimeFn indexFn localPath+        where+          serveFn = filePathSendFile+          indexFn fp =+              msum [ tryIndex filePathSendFile mimeFn ixFiles fp+                   , if browsing == EnableBrowsing+                        then browseIndex renderDirectoryContents filePathSendFile mimeFn ixFiles fp+                        else forbidden $ toResponse "Directory index forbidden"+                   ]++++-- | Ready collection of common mime types.+-- Except for the first two entries, the mappings come from http://svn.apache.org/viewvc/httpd/httpd/branches/2.4.x/docs/conf/mime.types?view=co+mimeTypes :: MimeMap+mimeTypes = Map.fromList [("gz","application/x-gzip"),("cabal","text/x-cabal"),("ez","application/andrew-inset"),("aw","application/applixware"),("atom","application/atom+xml"),("atomcat","application/atomcat+xml"),("atomsvc","application/atomsvc+xml"),("ccxml","application/ccxml+xml"),("cdmia","application/cdmi-capability"),("cdmic","application/cdmi-container"),("cdmid","application/cdmi-domain"),("cdmio","application/cdmi-object"),("cdmiq","application/cdmi-queue"),("cu","application/cu-seeme"),("davmount","application/davmount+xml"),("dbk","application/docbook+xml"),("dssc","application/dssc+der"),("xdssc","application/dssc+xml"),("ecma","application/ecmascript"),("emma","application/emma+xml"),("epub","application/epub+zip"),("exi","application/exi"),("pfr","application/font-tdpfr"),("gml","application/gml+xml"),("gpx","application/gpx+xml"),("gxf","application/gxf"),("stk","application/hyperstudio"),("ink","application/inkml+xml"),("inkml","application/inkml+xml"),("ipfix","application/ipfix"),("jar","application/java-archive"),("ser","application/java-serialized-object"),("class","application/java-vm"),("js","application/javascript"),("json","application/json"),("jsonml","application/jsonml+json"),("lostxml","application/lost+xml"),("hqx","application/mac-binhex40"),("cpt","application/mac-compactpro"),("mads","application/mads+xml"),("mrc","application/marc"),("mrcx","application/marcxml+xml"),("ma","application/mathematica"),("nb","application/mathematica"),("mb","application/mathematica"),("mathml","application/mathml+xml"),("mbox","application/mbox"),("mscml","application/mediaservercontrol+xml"),("metalink","application/metalink+xml"),("meta4","application/metalink4+xml"),("mets","application/mets+xml"),("mods","application/mods+xml"),("m21","application/mp21"),("mp21","application/mp21"),("mp4s","application/mp4"),("doc","application/msword"),("dot","application/msword"),("mxf","application/mxf"),("bin","application/octet-stream"),("dms","application/octet-stream"),("lrf","application/octet-stream"),("mar","application/octet-stream"),("so","application/octet-stream"),("dist","application/octet-stream"),("distz","application/octet-stream"),("pkg","application/octet-stream"),("bpk","application/octet-stream"),("dump","application/octet-stream"),("elc","application/octet-stream"),("deploy","application/octet-stream"),("oda","application/oda"),("opf","application/oebps-package+xml"),("ogx","application/ogg"),("omdoc","application/omdoc+xml"),("onetoc","application/onenote"),("onetoc2","application/onenote"),("onetmp","application/onenote"),("onepkg","application/onenote"),("oxps","application/oxps"),("xer","application/patch-ops-error+xml"),("pdf","application/pdf"),("pgp","application/pgp-encrypted"),("asc","application/pgp-signature"),("sig","application/pgp-signature"),("prf","application/pics-rules"),("p10","application/pkcs10"),("p7m","application/pkcs7-mime"),("p7c","application/pkcs7-mime"),("p7s","application/pkcs7-signature"),("p8","application/pkcs8"),("ac","application/pkix-attr-cert"),("cer","application/pkix-cert"),("crl","application/pkix-crl"),("pkipath","application/pkix-pkipath"),("pki","application/pkixcmp"),("pls","application/pls+xml"),("ai","application/postscript"),("eps","application/postscript"),("ps","application/postscript"),("cww","application/prs.cww"),("pskcxml","application/pskc+xml"),("rdf","application/rdf+xml"),("rif","application/reginfo+xml"),("rnc","application/relax-ng-compact-syntax"),("rl","application/resource-lists+xml"),("rld","application/resource-lists-diff+xml"),("rs","application/rls-services+xml"),("gbr","application/rpki-ghostbusters"),("mft","application/rpki-manifest"),("roa","application/rpki-roa"),("rsd","application/rsd+xml"),("rss","application/rss+xml"),("rtf","application/rtf"),("sbml","application/sbml+xml"),("scq","application/scvp-cv-request"),("scs","application/scvp-cv-response"),("spq","application/scvp-vp-request"),("spp","application/scvp-vp-response"),("sdp","application/sdp"),("setpay","application/set-payment-initiation"),("setreg","application/set-registration-initiation"),("shf","application/shf+xml"),("smi","application/smil+xml"),("smil","application/smil+xml"),("rq","application/sparql-query"),("srx","application/sparql-results+xml"),("gram","application/srgs"),("grxml","application/srgs+xml"),("sru","application/sru+xml"),("ssdl","application/ssdl+xml"),("ssml","application/ssml+xml"),("tei","application/tei+xml"),("teicorpus","application/tei+xml"),("tfi","application/thraud+xml"),("tsd","application/timestamped-data"),("plb","application/vnd.3gpp.pic-bw-large"),("psb","application/vnd.3gpp.pic-bw-small"),("pvb","application/vnd.3gpp.pic-bw-var"),("tcap","application/vnd.3gpp2.tcap"),("pwn","application/vnd.3m.post-it-notes"),("aso","application/vnd.accpac.simply.aso"),("imp","application/vnd.accpac.simply.imp"),("acu","application/vnd.acucobol"),("atc","application/vnd.acucorp"),("acutc","application/vnd.acucorp"),("air","application/vnd.adobe.air-application-installer-package+zip"),("fcdt","application/vnd.adobe.formscentral.fcdt"),("fxp","application/vnd.adobe.fxp"),("fxpl","application/vnd.adobe.fxp"),("xdp","application/vnd.adobe.xdp+xml"),("xfdf","application/vnd.adobe.xfdf"),("ahead","application/vnd.ahead.space"),("azf","application/vnd.airzip.filesecure.azf"),("azs","application/vnd.airzip.filesecure.azs"),("azw","application/vnd.amazon.ebook"),("acc","application/vnd.americandynamics.acc"),("ami","application/vnd.amiga.ami"),("apk","application/vnd.android.package-archive"),("cii","application/vnd.anser-web-certificate-issue-initiation"),("fti","application/vnd.anser-web-funds-transfer-initiation"),("atx","application/vnd.antix.game-component"),("mpkg","application/vnd.apple.installer+xml"),("m3u8","application/vnd.apple.mpegurl"),("swi","application/vnd.aristanetworks.swi"),("iota","application/vnd.astraea-software.iota"),("aep","application/vnd.audiograph"),("mpm","application/vnd.blueice.multipass"),("bmi","application/vnd.bmi"),("rep","application/vnd.businessobjects"),("cdxml","application/vnd.chemdraw+xml"),("mmd","application/vnd.chipnuts.karaoke-mmd"),("cdy","application/vnd.cinderella"),("cla","application/vnd.claymore"),("rp9","application/vnd.cloanto.rp9"),("c4g","application/vnd.clonk.c4group"),("c4d","application/vnd.clonk.c4group"),("c4f","application/vnd.clonk.c4group"),("c4p","application/vnd.clonk.c4group"),("c4u","application/vnd.clonk.c4group"),("c11amc","application/vnd.cluetrust.cartomobile-config"),("c11amz","application/vnd.cluetrust.cartomobile-config-pkg"),("csp","application/vnd.commonspace"),("cdbcmsg","application/vnd.contact.cmsg"),("cmc","application/vnd.cosmocaller"),("clkx","application/vnd.crick.clicker"),("clkk","application/vnd.crick.clicker.keyboard"),("clkp","application/vnd.crick.clicker.palette"),("clkt","application/vnd.crick.clicker.template"),("clkw","application/vnd.crick.clicker.wordbank"),("wbs","application/vnd.criticaltools.wbs+xml"),("pml","application/vnd.ctc-posml"),("ppd","application/vnd.cups-ppd"),("car","application/vnd.curl.car"),("pcurl","application/vnd.curl.pcurl"),("dart","application/vnd.dart"),("rdz","application/vnd.data-vision.rdz"),("uvf","application/vnd.dece.data"),("uvvf","application/vnd.dece.data"),("uvd","application/vnd.dece.data"),("uvvd","application/vnd.dece.data"),("uvt","application/vnd.dece.ttml+xml"),("uvvt","application/vnd.dece.ttml+xml"),("uvx","application/vnd.dece.unspecified"),("uvvx","application/vnd.dece.unspecified"),("uvz","application/vnd.dece.zip"),("uvvz","application/vnd.dece.zip"),("fe_launch","application/vnd.denovo.fcselayout-link"),("dna","application/vnd.dna"),("mlp","application/vnd.dolby.mlp"),("dpg","application/vnd.dpgraph"),("dfac","application/vnd.dreamfactory"),("kpxx","application/vnd.ds-keypoint"),("ait","application/vnd.dvb.ait"),("svc","application/vnd.dvb.service"),("geo","application/vnd.dynageo"),("mag","application/vnd.ecowin.chart"),("nml","application/vnd.enliven"),("esf","application/vnd.epson.esf"),("msf","application/vnd.epson.msf"),("qam","application/vnd.epson.quickanime"),("slt","application/vnd.epson.salt"),("ssf","application/vnd.epson.ssf"),("es3","application/vnd.eszigno3+xml"),("et3","application/vnd.eszigno3+xml"),("ez2","application/vnd.ezpix-album"),("ez3","application/vnd.ezpix-package"),("fdf","application/vnd.fdf"),("mseed","application/vnd.fdsn.mseed"),("seed","application/vnd.fdsn.seed"),("dataless","application/vnd.fdsn.seed"),("gph","application/vnd.flographit"),("ftc","application/vnd.fluxtime.clip"),("fm","application/vnd.framemaker"),("frame","application/vnd.framemaker"),("maker","application/vnd.framemaker"),("book","application/vnd.framemaker"),("fnc","application/vnd.frogans.fnc"),("ltf","application/vnd.frogans.ltf"),("fsc","application/vnd.fsc.weblaunch"),("oas","application/vnd.fujitsu.oasys"),("oa2","application/vnd.fujitsu.oasys2"),("oa3","application/vnd.fujitsu.oasys3"),("fg5","application/vnd.fujitsu.oasysgp"),("bh2","application/vnd.fujitsu.oasysprs"),("ddd","application/vnd.fujixerox.ddd"),("xdw","application/vnd.fujixerox.docuworks"),("xbd","application/vnd.fujixerox.docuworks.binder"),("fzs","application/vnd.fuzzysheet"),("txd","application/vnd.genomatix.tuxedo"),("ggb","application/vnd.geogebra.file"),("ggt","application/vnd.geogebra.tool"),("gex","application/vnd.geometry-explorer"),("gre","application/vnd.geometry-explorer"),("gxt","application/vnd.geonext"),("g2w","application/vnd.geoplan"),("g3w","application/vnd.geospace"),("gmx","application/vnd.gmx"),("kml","application/vnd.google-earth.kml+xml"),("kmz","application/vnd.google-earth.kmz"),("gqf","application/vnd.grafeq"),("gqs","application/vnd.grafeq"),("gac","application/vnd.groove-account"),("ghf","application/vnd.groove-help"),("gim","application/vnd.groove-identity-message"),("grv","application/vnd.groove-injector"),("gtm","application/vnd.groove-tool-message"),("tpl","application/vnd.groove-tool-template"),("vcg","application/vnd.groove-vcard"),("hal","application/vnd.hal+xml"),("zmm","application/vnd.handheld-entertainment+xml"),("hbci","application/vnd.hbci"),("les","application/vnd.hhe.lesson-player"),("hpgl","application/vnd.hp-hpgl"),("hpid","application/vnd.hp-hpid"),("hps","application/vnd.hp-hps"),("jlt","application/vnd.hp-jlyt"),("pcl","application/vnd.hp-pcl"),("pclxl","application/vnd.hp-pclxl"),("sfd-hdstx","application/vnd.hydrostatix.sof-data"),("mpy","application/vnd.ibm.minipay"),("afp","application/vnd.ibm.modcap"),("listafp","application/vnd.ibm.modcap"),("list3820","application/vnd.ibm.modcap"),("irm","application/vnd.ibm.rights-management"),("sc","application/vnd.ibm.secure-container"),("icc","application/vnd.iccprofile"),("icm","application/vnd.iccprofile"),("igl","application/vnd.igloader"),("ivp","application/vnd.immervision-ivp"),("ivu","application/vnd.immervision-ivu"),("igm","application/vnd.insors.igm"),("xpw","application/vnd.intercon.formnet"),("xpx","application/vnd.intercon.formnet"),("i2g","application/vnd.intergeo"),("qbo","application/vnd.intu.qbo"),("qfx","application/vnd.intu.qfx"),("rcprofile","application/vnd.ipunplugged.rcprofile"),("irp","application/vnd.irepository.package+xml"),("xpr","application/vnd.is-xpr"),("fcs","application/vnd.isac.fcs"),("jam","application/vnd.jam"),("rms","application/vnd.jcp.javame.midlet-rms"),("jisp","application/vnd.jisp"),("joda","application/vnd.joost.joda-archive"),("ktz","application/vnd.kahootz"),("ktr","application/vnd.kahootz"),("karbon","application/vnd.kde.karbon"),("chrt","application/vnd.kde.kchart"),("kfo","application/vnd.kde.kformula"),("flw","application/vnd.kde.kivio"),("kon","application/vnd.kde.kontour"),("kpr","application/vnd.kde.kpresenter"),("kpt","application/vnd.kde.kpresenter"),("ksp","application/vnd.kde.kspread"),("kwd","application/vnd.kde.kword"),("kwt","application/vnd.kde.kword"),("htke","application/vnd.kenameaapp"),("kia","application/vnd.kidspiration"),("kne","application/vnd.kinar"),("knp","application/vnd.kinar"),("skp","application/vnd.koan"),("skd","application/vnd.koan"),("skt","application/vnd.koan"),("skm","application/vnd.koan"),("sse","application/vnd.kodak-descriptor"),("lasxml","application/vnd.las.las+xml"),("lbd","application/vnd.llamagraphics.life-balance.desktop"),("lbe","application/vnd.llamagraphics.life-balance.exchange+xml"),("123","application/vnd.lotus-1-2-3"),("apr","application/vnd.lotus-approach"),("pre","application/vnd.lotus-freelance"),("nsf","application/vnd.lotus-notes"),("org","application/vnd.lotus-organizer"),("scm","application/vnd.lotus-screencam"),("lwp","application/vnd.lotus-wordpro"),("portpkg","application/vnd.macports.portpkg"),("mcd","application/vnd.mcd"),("mc1","application/vnd.medcalcdata"),("cdkey","application/vnd.mediastation.cdkey"),("mwf","application/vnd.mfer"),("mfm","application/vnd.mfmp"),("flo","application/vnd.micrografx.flo"),("igx","application/vnd.micrografx.igx"),("mif","application/vnd.mif"),("daf","application/vnd.mobius.daf"),("dis","application/vnd.mobius.dis"),("mbk","application/vnd.mobius.mbk"),("mqy","application/vnd.mobius.mqy"),("msl","application/vnd.mobius.msl"),("plc","application/vnd.mobius.plc"),("txf","application/vnd.mobius.txf"),("mpn","application/vnd.mophun.application"),("mpc","application/vnd.mophun.certificate"),("xul","application/vnd.mozilla.xul+xml"),("cil","application/vnd.ms-artgalry"),("cab","application/vnd.ms-cab-compressed"),("xls","application/vnd.ms-excel"),("xlm","application/vnd.ms-excel"),("xla","application/vnd.ms-excel"),("xlc","application/vnd.ms-excel"),("xlt","application/vnd.ms-excel"),("xlw","application/vnd.ms-excel"),("xlam","application/vnd.ms-excel.addin.macroenabled.12"),("xlsb","application/vnd.ms-excel.sheet.binary.macroenabled.12"),("xlsm","application/vnd.ms-excel.sheet.macroenabled.12"),("xltm","application/vnd.ms-excel.template.macroenabled.12"),("eot","application/vnd.ms-fontobject"),("chm","application/vnd.ms-htmlhelp"),("ims","application/vnd.ms-ims"),("lrm","application/vnd.ms-lrm"),("thmx","application/vnd.ms-officetheme"),("cat","application/vnd.ms-pki.seccat"),("stl","application/vnd.ms-pki.stl"),("ppt","application/vnd.ms-powerpoint"),("pps","application/vnd.ms-powerpoint"),("pot","application/vnd.ms-powerpoint"),("ppam","application/vnd.ms-powerpoint.addin.macroenabled.12"),("pptm","application/vnd.ms-powerpoint.presentation.macroenabled.12"),("sldm","application/vnd.ms-powerpoint.slide.macroenabled.12"),("ppsm","application/vnd.ms-powerpoint.slideshow.macroenabled.12"),("potm","application/vnd.ms-powerpoint.template.macroenabled.12"),("mpp","application/vnd.ms-project"),("mpt","application/vnd.ms-project"),("docm","application/vnd.ms-word.document.macroenabled.12"),("dotm","application/vnd.ms-word.template.macroenabled.12"),("wps","application/vnd.ms-works"),("wks","application/vnd.ms-works"),("wcm","application/vnd.ms-works"),("wdb","application/vnd.ms-works"),("wpl","application/vnd.ms-wpl"),("xps","application/vnd.ms-xpsdocument"),("mseq","application/vnd.mseq"),("mus","application/vnd.musician"),("msty","application/vnd.muvee.style"),("taglet","application/vnd.mynfc"),("nlu","application/vnd.neurolanguage.nlu"),("ntf","application/vnd.nitf"),("nitf","application/vnd.nitf"),("nnd","application/vnd.noblenet-directory"),("nns","application/vnd.noblenet-sealer"),("nnw","application/vnd.noblenet-web"),("ngdat","application/vnd.nokia.n-gage.data"),("n-gage","application/vnd.nokia.n-gage.symbian.install"),("rpst","application/vnd.nokia.radio-preset"),("rpss","application/vnd.nokia.radio-presets"),("edm","application/vnd.novadigm.edm"),("edx","application/vnd.novadigm.edx"),("ext","application/vnd.novadigm.ext"),("odc","application/vnd.oasis.opendocument.chart"),("otc","application/vnd.oasis.opendocument.chart-template"),("odb","application/vnd.oasis.opendocument.database"),("odf","application/vnd.oasis.opendocument.formula"),("odft","application/vnd.oasis.opendocument.formula-template"),("odg","application/vnd.oasis.opendocument.graphics"),("otg","application/vnd.oasis.opendocument.graphics-template"),("odi","application/vnd.oasis.opendocument.image"),("oti","application/vnd.oasis.opendocument.image-template"),("odp","application/vnd.oasis.opendocument.presentation"),("otp","application/vnd.oasis.opendocument.presentation-template"),("ods","application/vnd.oasis.opendocument.spreadsheet"),("ots","application/vnd.oasis.opendocument.spreadsheet-template"),("odt","application/vnd.oasis.opendocument.text"),("odm","application/vnd.oasis.opendocument.text-master"),("ott","application/vnd.oasis.opendocument.text-template"),("oth","application/vnd.oasis.opendocument.text-web"),("xo","application/vnd.olpc-sugar"),("dd2","application/vnd.oma.dd2+xml"),("oxt","application/vnd.openofficeorg.extension"),("pptx","application/vnd.openxmlformats-officedocument.presentationml.presentation"),("sldx","application/vnd.openxmlformats-officedocument.presentationml.slide"),("ppsx","application/vnd.openxmlformats-officedocument.presentationml.slideshow"),("potx","application/vnd.openxmlformats-officedocument.presentationml.template"),("xlsx","application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"),("xltx","application/vnd.openxmlformats-officedocument.spreadsheetml.template"),("docx","application/vnd.openxmlformats-officedocument.wordprocessingml.document"),("dotx","application/vnd.openxmlformats-officedocument.wordprocessingml.template"),("mgp","application/vnd.osgeo.mapguide.package"),("dp","application/vnd.osgi.dp"),("esa","application/vnd.osgi.subsystem"),("pdb","application/vnd.palm"),("pqa","application/vnd.palm"),("oprc","application/vnd.palm"),("paw","application/vnd.pawaafile"),("str","application/vnd.pg.format"),("ei6","application/vnd.pg.osasli"),("efif","application/vnd.picsel"),("wg","application/vnd.pmi.widget"),("plf","application/vnd.pocketlearn"),("pbd","application/vnd.powerbuilder6"),("box","application/vnd.previewsystems.box"),("mgz","application/vnd.proteus.magazine"),("qps","application/vnd.publishare-delta-tree"),("ptid","application/vnd.pvi.ptid1"),("qxd","application/vnd.quark.quarkxpress"),("qxt","application/vnd.quark.quarkxpress"),("qwd","application/vnd.quark.quarkxpress"),("qwt","application/vnd.quark.quarkxpress"),("qxl","application/vnd.quark.quarkxpress"),("qxb","application/vnd.quark.quarkxpress"),("bed","application/vnd.realvnc.bed"),("mxl","application/vnd.recordare.musicxml"),("musicxml","application/vnd.recordare.musicxml+xml"),("cryptonote","application/vnd.rig.cryptonote"),("cod","application/vnd.rim.cod"),("rm","application/vnd.rn-realmedia"),("rmvb","application/vnd.rn-realmedia-vbr"),("link66","application/vnd.route66.link66+xml"),("st","application/vnd.sailingtracker.track"),("see","application/vnd.seemail"),("sema","application/vnd.sema"),("semd","application/vnd.semd"),("semf","application/vnd.semf"),("ifm","application/vnd.shana.informed.formdata"),("itp","application/vnd.shana.informed.formtemplate"),("iif","application/vnd.shana.informed.interchange"),("ipk","application/vnd.shana.informed.package"),("twd","application/vnd.simtech-mindmapper"),("twds","application/vnd.simtech-mindmapper"),("mmf","application/vnd.smaf"),("teacher","application/vnd.smart.teacher"),("sdkm","application/vnd.solent.sdkm+xml"),("sdkd","application/vnd.solent.sdkm+xml"),("dxp","application/vnd.spotfire.dxp"),("sfs","application/vnd.spotfire.sfs"),("sdc","application/vnd.stardivision.calc"),("sda","application/vnd.stardivision.draw"),("sdd","application/vnd.stardivision.impress"),("smf","application/vnd.stardivision.math"),("sdw","application/vnd.stardivision.writer"),("vor","application/vnd.stardivision.writer"),("sgl","application/vnd.stardivision.writer-global"),("smzip","application/vnd.stepmania.package"),("sm","application/vnd.stepmania.stepchart"),("sxc","application/vnd.sun.xml.calc"),("stc","application/vnd.sun.xml.calc.template"),("sxd","application/vnd.sun.xml.draw"),("std","application/vnd.sun.xml.draw.template"),("sxi","application/vnd.sun.xml.impress"),("sti","application/vnd.sun.xml.impress.template"),("sxm","application/vnd.sun.xml.math"),("sxw","application/vnd.sun.xml.writer"),("sxg","application/vnd.sun.xml.writer.global"),("stw","application/vnd.sun.xml.writer.template"),("sus","application/vnd.sus-calendar"),("susp","application/vnd.sus-calendar"),("svd","application/vnd.svd"),("sis","application/vnd.symbian.install"),("sisx","application/vnd.symbian.install"),("xsm","application/vnd.syncml+xml"),("bdm","application/vnd.syncml.dm+wbxml"),("xdm","application/vnd.syncml.dm+xml"),("tao","application/vnd.tao.intent-module-archive"),("pcap","application/vnd.tcpdump.pcap"),("cap","application/vnd.tcpdump.pcap"),("dmp","application/vnd.tcpdump.pcap"),("tmo","application/vnd.tmobile-livetv"),("tpt","application/vnd.trid.tpt"),("mxs","application/vnd.triscape.mxs"),("tra","application/vnd.trueapp"),("ufd","application/vnd.ufdl"),("ufdl","application/vnd.ufdl"),("utz","application/vnd.uiq.theme"),("umj","application/vnd.umajin"),("unityweb","application/vnd.unity"),("uoml","application/vnd.uoml+xml"),("vcx","application/vnd.vcx"),("vsd","application/vnd.visio"),("vst","application/vnd.visio"),("vss","application/vnd.visio"),("vsw","application/vnd.visio"),("vis","application/vnd.visionary"),("vsf","application/vnd.vsf"),("wbxml","application/vnd.wap.wbxml"),("wmlc","application/vnd.wap.wmlc"),("wmlsc","application/vnd.wap.wmlscriptc"),("wtb","application/vnd.webturbo"),("nbp","application/vnd.wolfram.player"),("wpd","application/vnd.wordperfect"),("wqd","application/vnd.wqd"),("stf","application/vnd.wt.stf"),("xar","application/vnd.xara"),("xfdl","application/vnd.xfdl"),("hvd","application/vnd.yamaha.hv-dic"),("hvs","application/vnd.yamaha.hv-script"),("hvp","application/vnd.yamaha.hv-voice"),("osf","application/vnd.yamaha.openscoreformat"),("osfpvg","application/vnd.yamaha.openscoreformat.osfpvg+xml"),("saf","application/vnd.yamaha.smaf-audio"),("spf","application/vnd.yamaha.smaf-phrase"),("cmp","application/vnd.yellowriver-custom-menu"),("zir","application/vnd.zul"),("zirz","application/vnd.zul"),("zaz","application/vnd.zzazz.deck+xml"),("vxml","application/voicexml+xml"),("wgt","application/widget"),("hlp","application/winhlp"),("wsdl","application/wsdl+xml"),("wspolicy","application/wspolicy+xml"),("7z","application/x-7z-compressed"),("abw","application/x-abiword"),("ace","application/x-ace-compressed"),("dmg","application/x-apple-diskimage"),("aab","application/x-authorware-bin"),("x32","application/x-authorware-bin"),("u32","application/x-authorware-bin"),("vox","application/x-authorware-bin"),("aam","application/x-authorware-map"),("aas","application/x-authorware-seg"),("bcpio","application/x-bcpio"),("torrent","application/x-bittorrent"),("blb","application/x-blorb"),("blorb","application/x-blorb"),("bz","application/x-bzip"),("bz2","application/x-bzip2"),("boz","application/x-bzip2"),("cbr","application/x-cbr"),("cba","application/x-cbr"),("cbt","application/x-cbr"),("cbz","application/x-cbr"),("cb7","application/x-cbr"),("vcd","application/x-cdlink"),("cfs","application/x-cfs-compressed"),("chat","application/x-chat"),("pgn","application/x-chess-pgn"),("nsc","application/x-conference"),("cpio","application/x-cpio"),("csh","application/x-csh"),("deb","application/x-debian-package"),("udeb","application/x-debian-package"),("dgc","application/x-dgc-compressed"),("dir","application/x-director"),("dcr","application/x-director"),("dxr","application/x-director"),("cst","application/x-director"),("cct","application/x-director"),("cxt","application/x-director"),("w3d","application/x-director"),("fgd","application/x-director"),("swa","application/x-director"),("wad","application/x-doom"),("ncx","application/x-dtbncx+xml"),("dtb","application/x-dtbook+xml"),("res","application/x-dtbresource+xml"),("dvi","application/x-dvi"),("evy","application/x-envoy"),("eva","application/x-eva"),("bdf","application/x-font-bdf"),("gsf","application/x-font-ghostscript"),("psf","application/x-font-linux-psf"),("pcf","application/x-font-pcf"),("snf","application/x-font-snf"),("pfa","application/x-font-type1"),("pfb","application/x-font-type1"),("pfm","application/x-font-type1"),("afm","application/x-font-type1"),("arc","application/x-freearc"),("spl","application/x-futuresplash"),("gca","application/x-gca-compressed"),("ulx","application/x-glulx"),("gnumeric","application/x-gnumeric"),("gramps","application/x-gramps-xml"),("gtar","application/x-gtar"),("hdf","application/x-hdf"),("install","application/x-install-instructions"),("iso","application/x-iso9660-image"),("jnlp","application/x-java-jnlp-file"),("latex","application/x-latex"),("lzh","application/x-lzh-compressed"),("lha","application/x-lzh-compressed"),("mie","application/x-mie"),("prc","application/x-mobipocket-ebook"),("mobi","application/x-mobipocket-ebook"),("application","application/x-ms-application"),("lnk","application/x-ms-shortcut"),("wmd","application/x-ms-wmd"),("wmz","application/x-ms-wmz"),("xbap","application/x-ms-xbap"),("mdb","application/x-msaccess"),("obd","application/x-msbinder"),("crd","application/x-mscardfile"),("clp","application/x-msclip"),("exe","application/x-msdownload"),("dll","application/x-msdownload"),("com","application/x-msdownload"),("bat","application/x-msdownload"),("msi","application/x-msdownload"),("mvb","application/x-msmediaview"),("m13","application/x-msmediaview"),("m14","application/x-msmediaview"),("wmf","application/x-msmetafile"),("wmz","application/x-msmetafile"),("emf","application/x-msmetafile"),("emz","application/x-msmetafile"),("mny","application/x-msmoney"),("pub","application/x-mspublisher"),("scd","application/x-msschedule"),("trm","application/x-msterminal"),("wri","application/x-mswrite"),("nc","application/x-netcdf"),("cdf","application/x-netcdf"),("nzb","application/x-nzb"),("p12","application/x-pkcs12"),("pfx","application/x-pkcs12"),("p7b","application/x-pkcs7-certificates"),("spc","application/x-pkcs7-certificates"),("p7r","application/x-pkcs7-certreqresp"),("rar","application/x-rar-compressed"),("ris","application/x-research-info-systems"),("sh","application/x-sh"),("shar","application/x-shar"),("swf","application/x-shockwave-flash"),("xap","application/x-silverlight-app"),("sql","application/x-sql"),("sit","application/x-stuffit"),("sitx","application/x-stuffitx"),("srt","application/x-subrip"),("sv4cpio","application/x-sv4cpio"),("sv4crc","application/x-sv4crc"),("t3","application/x-t3vm-image"),("gam","application/x-tads"),("tar","application/x-tar"),("tcl","application/x-tcl"),("tex","application/x-tex"),("tfm","application/x-tex-tfm"),("texinfo","application/x-texinfo"),("texi","application/x-texinfo"),("obj","application/x-tgif"),("ustar","application/x-ustar"),("src","application/x-wais-source"),("der","application/x-x509-ca-cert"),("crt","application/x-x509-ca-cert"),("fig","application/x-xfig"),("xlf","application/x-xliff+xml"),("xpi","application/x-xpinstall"),("xz","application/x-xz"),("z1","application/x-zmachine"),("z2","application/x-zmachine"),("z3","application/x-zmachine"),("z4","application/x-zmachine"),("z5","application/x-zmachine"),("z6","application/x-zmachine"),("z7","application/x-zmachine"),("z8","application/x-zmachine"),("xaml","application/xaml+xml"),("xdf","application/xcap-diff+xml"),("xenc","application/xenc+xml"),("xhtml","application/xhtml+xml"),("xht","application/xhtml+xml"),("xml","application/xml"),("xsl","application/xml"),("dtd","application/xml-dtd"),("xop","application/xop+xml"),("xpl","application/xproc+xml"),("xslt","application/xslt+xml"),("xspf","application/xspf+xml"),("mxml","application/xv+xml"),("xhvml","application/xv+xml"),("xvml","application/xv+xml"),("xvm","application/xv+xml"),("yang","application/yang"),("yin","application/yin+xml"),("zip","application/zip"),("adp","audio/adpcm"),("au","audio/basic"),("snd","audio/basic"),("mid","audio/midi"),("midi","audio/midi"),("kar","audio/midi"),("rmi","audio/midi"),("m4a","audio/mp4"),("mp4a","audio/mp4"),("mpga","audio/mpeg"),("mp2","audio/mpeg"),("mp2a","audio/mpeg"),("mp3","audio/mpeg"),("m2a","audio/mpeg"),("m3a","audio/mpeg"),("oga","audio/ogg"),("ogg","audio/ogg"),("spx","audio/ogg"),("s3m","audio/s3m"),("sil","audio/silk"),("uva","audio/vnd.dece.audio"),("uvva","audio/vnd.dece.audio"),("eol","audio/vnd.digital-winds"),("dra","audio/vnd.dra"),("dts","audio/vnd.dts"),("dtshd","audio/vnd.dts.hd"),("lvp","audio/vnd.lucent.voice"),("pya","audio/vnd.ms-playready.media.pya"),("ecelp4800","audio/vnd.nuera.ecelp4800"),("ecelp7470","audio/vnd.nuera.ecelp7470"),("ecelp9600","audio/vnd.nuera.ecelp9600"),("rip","audio/vnd.rip"),("weba","audio/webm"),("aac","audio/x-aac"),("aif","audio/x-aiff"),("aiff","audio/x-aiff"),("aifc","audio/x-aiff"),("caf","audio/x-caf"),("flac","audio/x-flac"),("mka","audio/x-matroska"),("m3u","audio/x-mpegurl"),("wax","audio/x-ms-wax"),("wma","audio/x-ms-wma"),("ram","audio/x-pn-realaudio"),("ra","audio/x-pn-realaudio"),("rmp","audio/x-pn-realaudio-plugin"),("wav","audio/x-wav"),("xm","audio/xm"),("cdx","chemical/x-cdx"),("cif","chemical/x-cif"),("cmdf","chemical/x-cmdf"),("cml","chemical/x-cml"),("csml","chemical/x-csml"),("xyz","chemical/x-xyz"),("ttc","font/collection"),("otf","font/otf"),("ttf","font/ttf"),("woff","font/woff"),("woff2","font/woff2"),("bmp","image/bmp"),("cgm","image/cgm"),("g3","image/g3fax"),("gif","image/gif"),("ief","image/ief"),("jpeg","image/jpeg"),("jpg","image/jpeg"),("jpe","image/jpeg"),("ktx","image/ktx"),("png","image/png"),("btif","image/prs.btif"),("sgi","image/sgi"),("svg","image/svg+xml"),("svgz","image/svg+xml"),("tiff","image/tiff"),("tif","image/tiff"),("psd","image/vnd.adobe.photoshop"),("uvi","image/vnd.dece.graphic"),("uvvi","image/vnd.dece.graphic"),("uvg","image/vnd.dece.graphic"),("uvvg","image/vnd.dece.graphic"),("djvu","image/vnd.djvu"),("djv","image/vnd.djvu"),("sub","image/vnd.dvb.subtitle"),("dwg","image/vnd.dwg"),("dxf","image/vnd.dxf"),("fbs","image/vnd.fastbidsheet"),("fpx","image/vnd.fpx"),("fst","image/vnd.fst"),("mmr","image/vnd.fujixerox.edmics-mmr"),("rlc","image/vnd.fujixerox.edmics-rlc"),("mdi","image/vnd.ms-modi"),("wdp","image/vnd.ms-photo"),("npx","image/vnd.net-fpx"),("wbmp","image/vnd.wap.wbmp"),("xif","image/vnd.xiff"),("webp","image/webp"),("3ds","image/x-3ds"),("ras","image/x-cmu-raster"),("cmx","image/x-cmx"),("fh","image/x-freehand"),("fhc","image/x-freehand"),("fh4","image/x-freehand"),("fh5","image/x-freehand"),("fh7","image/x-freehand"),("ico","image/x-icon"),("sid","image/x-mrsid-image"),("pcx","image/x-pcx"),("pic","image/x-pict"),("pct","image/x-pict"),("pnm","image/x-portable-anymap"),("pbm","image/x-portable-bitmap"),("pgm","image/x-portable-graymap"),("ppm","image/x-portable-pixmap"),("rgb","image/x-rgb"),("tga","image/x-tga"),("xbm","image/x-xbitmap"),("xpm","image/x-xpixmap"),("xwd","image/x-xwindowdump"),("eml","message/rfc822"),("mime","message/rfc822"),("igs","model/iges"),("iges","model/iges"),("msh","model/mesh"),("mesh","model/mesh"),("silo","model/mesh"),("dae","model/vnd.collada+xml"),("dwf","model/vnd.dwf"),("gdl","model/vnd.gdl"),("gtw","model/vnd.gtw"),("mts","model/vnd.mts"),("vtu","model/vnd.vtu"),("wrl","model/vrml"),("vrml","model/vrml"),("x3db","model/x3d+binary"),("x3dbz","model/x3d+binary"),("x3dv","model/x3d+vrml"),("x3dvz","model/x3d+vrml"),("x3d","model/x3d+xml"),("x3dz","model/x3d+xml"),("appcache","text/cache-manifest"),("ics","text/calendar"),("ifb","text/calendar"),("css","text/css"),("csv","text/csv"),("html","text/html"),("htm","text/html"),("n3","text/n3"),("txt","text/plain"),("text","text/plain"),("conf","text/plain"),("def","text/plain"),("list","text/plain"),("log","text/plain"),("in","text/plain"),("dsc","text/prs.lines.tag"),("rtx","text/richtext"),("sgml","text/sgml"),("sgm","text/sgml"),("tsv","text/tab-separated-values"),("t","text/troff"),("tr","text/troff"),("roff","text/troff"),("man","text/troff"),("me","text/troff"),("ms","text/troff"),("ttl","text/turtle"),("uri","text/uri-list"),("uris","text/uri-list"),("urls","text/uri-list"),("vcard","text/vcard"),("curl","text/vnd.curl"),("dcurl","text/vnd.curl.dcurl"),("mcurl","text/vnd.curl.mcurl"),("scurl","text/vnd.curl.scurl"),("sub","text/vnd.dvb.subtitle"),("fly","text/vnd.fly"),("flx","text/vnd.fmi.flexstor"),("gv","text/vnd.graphviz"),("3dml","text/vnd.in3d.3dml"),("spot","text/vnd.in3d.spot"),("jad","text/vnd.sun.j2me.app-descriptor"),("wml","text/vnd.wap.wml"),("wmls","text/vnd.wap.wmlscript"),("s","text/x-asm"),("asm","text/x-asm"),("c","text/x-c"),("cc","text/x-c"),("cxx","text/x-c"),("cpp","text/x-c"),("h","text/x-c"),("hh","text/x-c"),("dic","text/x-c"),("f","text/x-fortran"),("for","text/x-fortran"),("f77","text/x-fortran"),("f90","text/x-fortran"),("java","text/x-java-source"),("nfo","text/x-nfo"),("opml","text/x-opml"),("p","text/x-pascal"),("pas","text/x-pascal"),("etx","text/x-setext"),("sfv","text/x-sfv"),("uu","text/x-uuencode"),("vcs","text/x-vcalendar"),("vcf","text/x-vcard"),("3gp","video/3gpp"),("3g2","video/3gpp2"),("h261","video/h261"),("h263","video/h263"),("h264","video/h264"),("jpgv","video/jpeg"),("jpm","video/jpm"),("jpgm","video/jpm"),("mj2","video/mj2"),("mjp2","video/mj2"),("mp4","video/mp4"),("mp4v","video/mp4"),("mpg4","video/mp4"),("mpeg","video/mpeg"),("mpg","video/mpeg"),("mpe","video/mpeg"),("m1v","video/mpeg"),("m2v","video/mpeg"),("ogv","video/ogg"),("qt","video/quicktime"),("mov","video/quicktime"),("uvh","video/vnd.dece.hd"),("uvvh","video/vnd.dece.hd"),("uvm","video/vnd.dece.mobile"),("uvvm","video/vnd.dece.mobile"),("uvp","video/vnd.dece.pd"),("uvvp","video/vnd.dece.pd"),("uvs","video/vnd.dece.sd"),("uvvs","video/vnd.dece.sd"),("uvv","video/vnd.dece.video"),("uvvv","video/vnd.dece.video"),("dvb","video/vnd.dvb.file"),("fvt","video/vnd.fvt"),("mxu","video/vnd.mpegurl"),("m4u","video/vnd.mpegurl"),("pyv","video/vnd.ms-playready.media.pyv"),("uvu","video/vnd.uvvu.mp4"),("uvvu","video/vnd.uvvu.mp4"),("viv","video/vnd.vivo"),("webm","video/webm"),("f4v","video/x-f4v"),("fli","video/x-fli"),("flv","video/x-flv"),("m4v","video/x-m4v"),("mkv","video/x-matroska"),("mk3d","video/x-matroska"),("mks","video/x-matroska"),("mng","video/x-mng"),("asf","video/x-ms-asf"),("asx","video/x-ms-asf"),("vob","video/x-ms-vob"),("wm","video/x-ms-wm"),("wmv","video/x-ms-wmv"),("wmx","video/x-ms-wmx"),("wvx","video/x-ms-wvx"),("avi","video/x-msvideo"),("movie","video/x-sgi-movie"),("smv","video/x-smv"),("ice","x-conference/x-cooltalk")]
− src/Happstack/Server/HTTP/Client.hs 
@@ -1,50 +0,0 @@-module Happstack.Server.HTTP.Client where---import Happstack.Server.HTTP.Handler-import Happstack.Server.HTTP.Types-import Data.Maybe-import qualified Data.ByteString.Lazy.Char8 as L --import System.IO-import qualified Data.ByteString.Char8 as B -import Network--getResponse :: Request -> IO (Either String Response)-getResponse rq = withSocketsDo $ do-  let (hostName,p) = span (/=':') $ fromJust $ fmap B.unpack $ getHeader "host" rq -      portInt = if null p then 80 else read $ tail p-      portId = PortNumber $ toEnum $ portInt-  h <- connectTo hostName portId -  hSetBuffering h NoBuffering--  putRequest h rq-  hFlush h--  inputStr <- L.hGetContents h-  return $ parseResponse inputStr--unproxify :: Request -> Request-unproxify rq = rq {rqPaths = tail $ rqPaths rq,-                   rqHeaders = -                       forwardedFor $ forwardedHost $ -                       setHeader "host" (head $ rqPaths rq) $-                   rqHeaders rq}-  where-  appendInfo hdr val = setHeader hdr (csv val $-                                        maybe "" B.unpack $-                                        getHeader hdr rq)-  forwardedFor = appendInfo "X-Forwarded-For" (fst $ rqPeer rq)-  forwardedHost = appendInfo "X-Forwarded-Host" -                  (B.unpack $ fromJust $ getHeader "host" rq)-  csv v "" = v-  csv v x = x++", " ++ v--unrproxify :: String -> [(String, String)] -> Request -> Request-unrproxify defaultHost list rq = unproxify rq {rqPaths = host: rqPaths rq}-  where-  host::String-  host = maybe defaultHost (f .B.unpack) $-         getHeader "host" rq-  f = maybe defaultHost id . flip lookup list-
− src/Happstack/Server/HTTP/Clock.hs 
@@ -1,30 +0,0 @@-{-# OPTIONS -fno-cse #-}-module Happstack.Server.HTTP.Clock(getApproximateTime) where--import Control.Concurrent-import Data.IORef-import System.IO.Unsafe-import System.Time-import System.Locale--import qualified Data.ByteString.Char8 as B--mkTime :: IO B.ByteString-mkTime = do now <- getClockTime-            return $ B.pack (formatCalendarTime defaultTimeLocale "%a, %d %b %Y %X GMT" (toUTCTime now))---{-# NOINLINE clock #-}-clock :: IORef B.ByteString-clock = unsafePerformIO $ do-  ref <- newIORef =<< mkTime-  forkIO $ updater ref-  return ref--updater :: IORef B.ByteString -> IO ()-updater ref = do threadDelay (10^(6 :: Int) * 1) -- Every second-                 writeIORef ref =<< mkTime-                 updater ref--getApproximateTime :: IO B.ByteString-getApproximateTime = readIORef clock
− src/Happstack/Server/HTTP/FileServe.hs 
@@ -1,215 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Happstack.Server.HTTP.FileServe-    (-     MimeMap,fileServe, mimeTypes,isDot, blockDotFiles,doIndex,errorwrapper-    ) where--import Control.Exception.Extensible--import Control.Monad.Reader-import Control.Monad.Trans-import Data.List-import Data.Maybe-import Data.Int-import Happstack.Server.SimpleHTTP hiding (path)-import System.Directory-import System.IO-import System.Locale(defaultTimeLocale)-import System.Log.Logger-import System.Time -- (formatCalendarTime, toUTCTime,TOD(..))-import qualified Data.ByteString.Char8 as P-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.Map as Map-import qualified Happstack.Server.SimpleHTTP as SH--ioErrors :: SomeException -> Maybe IOException-ioErrors = fromException--errorwrapper :: (MonadIO m, MonadPlus m, FilterMonad Response m) => String -> String -> m Response-errorwrapper binarylocation loglocation-    = require getErrorLog $ \errorLog ->-      return $ toResponse errorLog-    where getErrorLog-                = handleJust ioErrors (const (return Nothing)) $-                do bintime <- getModificationTime binarylocation-                   logtime <- getModificationTime loglocation-                   if (logtime > bintime)-                     then fmap Just $ readFile loglocation -- fileServe [loglocation] [] "./"-                     else return Nothing--type MimeMap = Map.Map String String--doIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>-           [String] -> MimeMap -> String -> m Response-doIndex [] _mime _fp = do forbidden $ toResponse "Directory index forbidden"-doIndex (index:rest) mime fp =-    do-    let path = fp++'/':index-    --print path-    fe <- liftIO $ doesFileExist path-    if fe then retFile path else doIndex rest mime fp-    where retFile = returnFile mime-defaultIxFiles :: [String]-defaultIxFiles= ["index.html","index.xml","index.gif"]---fileServe :: (ServerMonad m, FilterMonad Response m, MonadIO m) => [FilePath] -> FilePath -> m Response-fileServe ixFiles localpath  = -    fileServe' localpath (doIndex (ixFiles++defaultIxFiles)) mimeTypes---- | Serve files with a mime type map under a directory.---   Uses the function to transform URIs to FilePaths.-fileServe' :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>-              String-              -> (Map.Map String String -> String -> m Response)-              -> Map.Map String String-              -> m Response-fileServe' localpath fdir mime = do-    rq <- askRq-    let fp2 = takeWhile (/=',') fp-        fp = filepath-        safepath = filter (\x->not (null x) && head x /= '.') (rqPaths rq)-        filepath = intercalate "/"  (localpath:safepath)-        fp' = if null safepath then "" else last safepath-    if "TESTH" `isPrefixOf` fp'-        then renderResponse mime $ fakeFile $ (read $ drop 5 $ fp' :: Integer)-        else do-    fe <- liftIO $ doesFileExist fp-    fe2 <- liftIO $ doesFileExist fp2-    de <- liftIO $ doesDirectoryExist fp-    -- error $ "show ilepath: " ++show (fp,de)-    let status | de   = "DIR"-               | fe   = "file"-               | fe2  = "group"-               | True = "NOT FOUND"-    liftIO $ logM "Happstack.Server.HTTP.FileServe" DEBUG ("fileServe: "++show fp++" \t"++status)-    if de then fdir mime fp else do-    getFile mime fp >>= flip either (renderResponse mime) -                (const $ returnGroup localpath mime safepath)--returnFile :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>-              Map.Map String String -> String -> m Response-returnFile mime fp =  -    getFile mime fp >>=  either fileNotFound (renderResponse mime)---- if fp has , separated then return concatenation with content-type of last--- and last modified of latest-tr :: (Eq a) => a -> a -> [a] -> [a]-tr a b = map (\x->if x==a then b else x)-ltrim :: String -> String-ltrim = dropWhile (flip elem " \t\r")   --returnGroup :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>-               String -> Map.Map String String -> [String] -> m Response-returnGroup localPath mime fp = do-  let fps0 = map ((:[]). ltrim) $ lines $ tr ',' '\n' $ last fp-      fps = map (intercalate "/" . ((localPath:init fp) ++)) fps0--  -- if (head $ head fps0)=="TEST" then   renderResponse mime rq fakeFile else do--  mbFiles <-  mapM (getFile mime) $ fps-  let notFounds = [x | Left x <- mbFiles]-      files = [x | Right x <- mbFiles]-  if not $ null notFounds -    then fileNotFound $ drop (length localPath) $ head notFounds else do-  let totSize = sum $ map (snd . fst) files-      maxTime = maximum $ map (fst . fst) files :: ClockTime--  renderResponse mime ((maxTime,totSize),(fst $ snd $ head files,-                                             L.concat $ map (snd . snd) files))----fileNotFound :: (Monad m, FilterMonad Response m) => String -> m Response-fileNotFound fp = do setResponseCode 404 -                     return $ toResponse $ "File not found "++ fp---fakeLen = 71* 1024-fakeFile :: (Integral a) =>-            a -> ((ClockTime, Int64), (String, L.ByteString))-fakeFile fakeLen = ((TOD 0 0,L.length body),("text/javascript",body))-    where-      body = L.pack $ (("//"++(show len)++" ") ++ ) $ (replicate len '0') ++ "\n"-      len = fromIntegral fakeLen--getFile :: (MonadIO m) =>-           Map.Map String String-           -> String-           -> m (Either String ((ClockTime, Integer), (String, L.ByteString)))-getFile mime fp = do-  let ct = Map.findWithDefault "text/plain" (getExt fp) mime-  fe <- liftIO $ doesFileExist fp-  if not fe then return $ Left fp else do-  -  time <- liftIO  $ getModificationTime fp-  h <- liftIO $ openBinaryFile fp ReadMode-  size <- liftIO $ hFileSize h-  lbs <- liftIO $ L.hGetContents h-  return $ Right ((time,size),(ct,lbs))--renderResponse :: (Monad m,-                   ServerMonad m,-                   FilterMonad Response m,-                   Show t1) =>-                  t-                  -> ((ClockTime, t1), (String, L.ByteString))-                  -> m Response-renderResponse _ ((modtime,size),(ct,body)) = do-  rq <- askRq-  let notmodified = getHeader "if-modified-since" rq == Just (P.pack $ repr)-      repr = formatCalendarTime defaultTimeLocale -             "%a, %d %b %Y %X GMT" (toUTCTime modtime)-  -- "Mon, 07 Jan 2008 19:51:02 GMT"-  -- when (isJust $ getHeader "if-modified-since"  rq) $ error $ show $ getHeader "if-modified-since" rq-  if notmodified then do setResponseCode 304 ; return $ toResponse "" else do-  --  modifyResponse (setHeader "HUH" $ show $ (fmap P.unpack mod == Just repr,mod,Just repr))-  setHeaderM "Last-modified" repr-  -- if %Z or UTC are in place of GMT below, wget complains that the last-modified header is invalid-  setHeaderM "Content-Length" (show size)-  setHeaderM "Content-Type" ct-  return $ resultBS 200 body--              ---getExt :: String -> String-getExt = reverse . takeWhile (/='.') . reverse---- | Ready collection of common mime types.-mimeTypes :: MimeMap-mimeTypes = Map.fromList-	    [("xml","application/xml")-	    ,("xsl","application/xml")-	    ,("js","text/javascript")-	    ,("html","text/html")-	    ,("css","text/css")-	    ,("gif","image/gif")-	    ,("jpg","image/jpeg")-	    ,("png","image/png")-	    ,("txt","text/plain")-	    ,("doc","application/msword")-	    ,("exe","application/octet-stream")-	    ,("pdf","application/pdf")-	    ,("zip","application/zip")-	    ,("gz","application/x-gzip")-	    ,("ps","application/postscript")-	    ,("rtf","application/rtf")-	    ,("wav","application/x-wav")-	    ,("hs","text/plain")]----- | Prevents files of the form '.foo' or 'bar/.foo' from being served-blockDotFiles :: (Request -> IO Response) -> Request -> IO Response-blockDotFiles fn rq-    | isDot (intercalate "/" (rqPaths rq)) = return $ result 403 "Dot files not allowed."-    | otherwise = fn rq---- | Returns True if the given String either starts with a . or is of the form--- "foo/.bar", e.g. the typical *nix convention for hidden files.-isDot :: String -> Bool-isDot = isD . reverse-    where-    isD ('.':'/':_) = True-    isD ['.']       = True-    --isD ('/':_)     = False-    isD (_:cs)      = isD cs-    isD []          = False
− src/Happstack/Server/HTTP/Handler.hs 
@@ -1,322 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}--module Happstack.Server.HTTP.Handler(request-- version,required-  ,parseResponse,putRequest--- ,unchunkBody,val,testChunk,pack-) where---    ,fsepC,crlfC,pversion-import qualified Paths_happstack_server as Paths-import qualified Data.Version as DV-import Control.Exception.Extensible as E-import Control.Monad-import Data.List(elemIndex)-import Data.Char(toLower)-import Data.Maybe ( fromMaybe, fromJust, isJust, isNothing )-import Prelude hiding (last)-import qualified Data.List as List-import qualified Data.ByteString.Char8 as P-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.Map as M-import System.IO-import Numeric-import Data.Int (Int64)-import Happstack.Server.Cookie-import Happstack.Server.HTTP.Clock-import Happstack.Server.HTTP.LazyLiner-import Happstack.Server.HTTP.Types-import Happstack.Server.HTTP.Multipart-import Happstack.Server.HTTP.RFC822Headers-import Happstack.Server.MessageWrap-import Happstack.Server.SURI(SURI(..),path,query)-import Happstack.Server.SURI.ParseURI-import Happstack.Util.TimeOut-import Happstack.Util.LogFormat (formatRequestCombined)-import Data.Time.Clock (getCurrentTime)-import System.Log.Logger (Priority(..), logM)--log' = logM "Happstack.Server"--request :: Conf -> Handle -> Host -> (Request -> IO Response) -> IO ()-request conf h host handler = rloop conf h host handler =<< L.hGetContents h--required :: String -> Maybe a -> Either String a-required err Nothing  = Left err-required _   (Just a) = Right a--transferEncodingC :: [Char]-transferEncodingC = "transfer-encoding"-rloop :: t-         -> Handle-         -> Host-         -> (Request -> IO Response)-         -> L.ByteString-         -> IO ()-rloop conf h host handler inputStr-    | L.null inputStr = return ()-    | otherwise-    = join $ withTimeOut (30 * second) $-      do let parseRequest-                 = do (topStr, restStr) <- required "failed to separate request" $ splitAtEmptyLine inputStr-                      (rql, headerStr) <- required "failed to separate headers/body" $ splitAtCRLF topStr-                      let (m,u,v) = requestLine rql-                      headers' <- parseHeaders "host" (L.unpack headerStr)-                      let headers = mkHeaders headers'-                      let contentLength = fromMaybe 0 $ fmap fst (P.readInt =<< getHeaderUnsafe contentlengthC headers)-                      (body, nextRequest) <- case () of-                          () | contentLength < 0               -> fail "negative content-length"-                             | isJust $ getHeader transferEncodingC headers ->-                                 return $ consumeChunks restStr-                             | otherwise                       -> return (L.splitAt (fromIntegral contentLength) restStr)-                      let cookies = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" headers)), c <- cl ] -- Ugle-                          rqTmp = Request m (pathEls (path u)) (path u) (query u) -                                  [] cookies v headers (Body body) host-                          rq = rqTmp{rqInputs = queryInput u ++ bodyInput rqTmp}-                      return (rq, nextRequest)-         case parseRequest of-           Left err -> error $ "failed to parse HTTP request: " ++ err-           Right (req, rest)-               -> return $-                  do let ioseq act = act >>= \x -> x `seq` return x-                     res <- ioseq (handler req) `E.catch` \(e::E.SomeException) -> return $ result 500 $ "Server error: " ++ show e-                     -                     -- combined log format-                     time <- getCurrentTime-                     let host' = fst host-                         user = "-"-                         requestLine = unwords [show $ rqMethod req, rqUri req, show $ rqVersion req]-                         responseCode = rsCode res-                         size = toInteger $ L.length $ rsBody res-                         referer = B.unpack $ fromMaybe (B.pack "") $ getHeader "Referer" req-                         userAgent = B.unpack $ fromMaybe (B.pack "") $ getHeader "User-Agent" req-                     log' NOTICE $ formatRequestCombined host' user time requestLine responseCode size referer userAgent-                     -                     putAugmentedResult h req res-                     when (continueHTTP req res) $ rloop conf h host handler rest--parseResponse :: L.ByteString -> Either String Response-parseResponse inputStr =-    do (topStr,restStr) <- required "failed to separate response" $ -                           splitAtEmptyLine inputStr-       (rsl,headerStr) <- required "failed to separate headers/body" $-                          splitAtCRLF topStr-       let (_,code) = responseLine rsl-       headers' <- parseHeaders "host" (L.unpack headerStr)-       let headers = mkHeaders headers'-       let mbCL = fmap fst (B.readInt =<< getHeader "content-length" headers)-       (body,_) <--           maybe (if (isNothing $ getHeader "transfer-encoding" headers) -                       then  return (restStr,L.pack "") -                       else  return $ consumeChunks restStr)-                 (\cl->return (L.splitAt (fromIntegral cl) restStr))-                 mbCL-       return $ Response {rsCode=code,rsHeaders=headers,rsBody=body,rsFlags=RsFlags True,rsValidator=Nothing}---- http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html--- note this does NOT handle extenions-consumeChunks::L.ByteString->(L.ByteString,L.ByteString)-consumeChunks str = let (parts,tr,rest) = consumeChunksImpl str in (L.concat . (++ [tr]) .map snd $ parts,rest)--consumeChunksImpl :: L.ByteString -> ([(Int64, L.ByteString)], L.ByteString, L.ByteString)-consumeChunksImpl str-    | L.null str = ([],L.empty,str)-    | chunkLen == 0 = let (last,rest') = L.splitAt lenLine1 str-                          (tr',rest'') = getTrailer rest' -                      in ([(0,last)],tr',rest'')-    | otherwise = ((chunkLen,part):crest,tr,rest2)-    where-      line1 = head $ lazylines str -      lenLine1 = (L.length line1) + 1 -- endchar-      chunkLen = (fst $ head $ readHex $ L.unpack line1)-      len = chunkLen + lenLine1 + 2-      (part,rest) = L.splitAt len str-      (crest,tr,rest2) = consumeChunksImpl rest-      getTrailer s = L.splitAt index s-          where index | crlfLC `L.isPrefixOf` s = 2-                      | otherwise = let iscrlf = L.zipWith (\a b -> a == '\r' && b == '\n') s . L.tail $ s-                                        Just i = elemIndex True $ zipWith (&&) iscrlf (tail (tail iscrlf))-                                    in fromIntegral $ i+4--crlfLC :: L.ByteString-crlfLC = L.pack "\r\n"---- Properly lazy version of 'lines' for lazy bytestrings-lazylines           :: L.ByteString -> [L.ByteString]-lazylines s-    | L.null s  = []-    | otherwise =-        let (l,s') = L.break ((==) '\n') s-        in l : if L.null s' then []-                            else lazylines (L.tail s')--requestLine :: L.ByteString -> (Method, SURI, Version)-requestLine l = case P.words ((P.concat . L.toChunks) l) of-                  [rq,uri,ver] -> (method rq, SURI $ parseURIRef uri, version ver)-                  [rq,uri] -> (method rq, SURI $ parseURIRef uri,Version 0 9)-                  x -> error $ "requestLine cannot handle input:  " ++ (show x)--responseLine :: L.ByteString -> (B.ByteString, Int)-responseLine l = case B.words ((B.concat . L.toChunks) l) of -                   (v:c:_) -> version v `seq` (v,fst (fromJust (B.readInt c)))-                   x -> error $ "responseLine cannot handle input: " ++ (show x)---method :: B.ByteString -> Method-method r = fj $ lookup r mtable-    where fj (Just x) = x-          fj Nothing  = error "invalid request method"-          mtable = [(P.pack "GET",     GET),-                    (P.pack "HEAD",    HEAD),-                    (P.pack "POST",    POST),-                    (P.pack "PUT",     PUT),-                    (P.pack "DELETE",  DELETE),-                    (P.pack "TRACE",   TRACE),-                    (P.pack "OPTIONS", OPTIONS),-                    (P.pack "CONNECT", CONNECT)]---- Result side--staticHeaders :: Headers-staticHeaders =-    foldr (uncurry setHeaderBS) (mkHeaders [])-    [ (serverC, happsC), (contentTypeC, textHtmlC) ]--putAugmentedResult :: Handle -> Request -> Response -> IO ()-putAugmentedResult h req res = do-  let ph (HeaderPair k vs) = map (\v -> P.concat [k, fsepC, v, crlfC]) vs-  raw <- getApproximateTime-  let cl = L.length $ rsBody res-  let put = P.hPut h-  -- TODO: Hoist static headers to the toplevel.-  let stdHeaders = staticHeaders `M.union`-                   M.fromList ( [ (dateCLower,       HeaderPair dateC [raw])-                                , (connectionCLower, HeaderPair connectionC [if continueHTTP req res then keepAliveC else closeC])-                                ] ++ if rsfContentLength (rsFlags res)-                                     then [(contentlengthC, HeaderPair contentLengthC [P.pack (show cl)])]-                                     else [] )-      allHeaders = rsHeaders res `M.union` stdHeaders  -- 'union' prefers 'headers res' when duplicate keys are encountered.--  mapM_ put $ concat-    [ (pversion $ rqVersion req)          -- Print HTTP version-    , [responseMessage $ rsCode res]      -- Print responseCode-    , concatMap ph (M.elems allHeaders)   -- Print all headers-    , [crlfC]-    ]-  when (rqMethod req /= HEAD) $ L.hPut h $ rsBody res-  hFlush h---putRequest :: Handle -> Request -> IO ()-putRequest h rq = do -    let put = B.hPut h-        ph (HeaderPair k vs) = map (\v -> B.concat [k, fsepC, v, crlfC]) vs-        sp = [B.pack " "]-    mapM_ put $ concat-      [[B.pack $ show $ rqMethod rq],sp-      ,[B.pack $ rqURL rq],sp-      ,(pversion $ rqVersion rq), [crlfC]-      ,concatMap ph (M.elems $ rqHeaders rq)-      ,[crlfC]-      ]-    let Body body = rqBody rq-    L.hPut h  body-    hFlush h------ Version--pversion :: Version -> [B.ByteString]-pversion (Version 1 1) = [http11]-pversion (Version 1 0) = [http10]-pversion (Version x y) = [P.pack "HTTP/", P.pack (show x), P.pack ".", P.pack (show y)]--version :: B.ByteString -> Version-version x | x == http09 = Version 0 9-          | x == http10 = Version 1 0-          | x == http11 = Version 1 1-          | otherwise   = error "Invalid HTTP version"--http09 :: B.ByteString-http09 = P.pack "HTTP/0.9"-http10 :: B.ByteString-http10 = P.pack "HTTP/1.0"-http11 :: B.ByteString-http11 = P.pack "HTTP/1.1"---- Constants--connectionC :: B.ByteString-connectionC      = P.pack "Connection"-connectionCLower :: B.ByteString-connectionCLower = P.map toLower connectionC-closeC :: B.ByteString-closeC           = P.pack "close"-keepAliveC :: B.ByteString-keepAliveC       = P.pack "Keep-Alive"-crlfC :: B.ByteString-crlfC            = P.pack "\r\n"-fsepC :: B.ByteString-fsepC            = P.pack ": "-contentTypeC :: B.ByteString-contentTypeC     = P.pack "Content-Type"-contentLengthC :: B.ByteString-contentLengthC   = P.pack "Content-Length"-contentlengthC :: B.ByteString-contentlengthC   = P.pack "content-length"-dateC :: B.ByteString-dateC            = P.pack "Date"-dateCLower :: B.ByteString-dateCLower       = P.map toLower dateC-serverC :: B.ByteString-serverC          = P.pack "Server"-happsC :: B.ByteString-happsC           = P.pack $ "Happstack/" ++ DV.showVersion Paths.version-textHtmlC :: B.ByteString-textHtmlC        = P.pack "text/html; charset=utf-8"---- Response code names--responseMessage :: (Num t) => t -> B.ByteString-responseMessage 100 = P.pack " 100 Continue\r\n"-responseMessage 101 = P.pack " 101 Switching Protocols\r\n"-responseMessage 200 = P.pack " 200 OK\r\n"-responseMessage 201 = P.pack " 201 Created\r\n"-responseMessage 202 = P.pack " 202 Accepted\r\n"-responseMessage 203 = P.pack " 203 Non-Authoritative Information\r\n"-responseMessage 204 = P.pack " 204 No Content\r\n"-responseMessage 205 = P.pack " 205 Reset Content\r\n"-responseMessage 206 = P.pack " 206 Partial Content\r\n"-responseMessage 300 = P.pack " 300 Multiple Choices\r\n"-responseMessage 301 = P.pack " 301 Moved Permanently\r\n"-responseMessage 302 = P.pack " 302 Found\r\n"-responseMessage 303 = P.pack " 303 See Other\r\n"-responseMessage 304 = P.pack " 304 Not Modified\r\n"-responseMessage 305 = P.pack " 305 Use Proxy\r\n"-responseMessage 307 = P.pack " 307 Temporary Redirect\r\n"-responseMessage 400 = P.pack " 400 Bad Request\r\n"-responseMessage 401 = P.pack " 401 Unauthorized\r\n"-responseMessage 402 = P.pack " 402 Payment Required\r\n"-responseMessage 403 = P.pack " 403 Forbidden\r\n"-responseMessage 404 = P.pack " 404 Not Found\r\n"-responseMessage 405 = P.pack " 405 Method Not Allowed\r\n"-responseMessage 406 = P.pack " 406 Not Acceptable\r\n"-responseMessage 407 = P.pack " 407 Proxy Authentication Required\r\n"-responseMessage 408 = P.pack " 408 Request Time-out\r\n"-responseMessage 409 = P.pack " 409 Conflict\r\n"-responseMessage 410 = P.pack " 410 Gone\r\n"-responseMessage 411 = P.pack " 411 Length Required\r\n"-responseMessage 412 = P.pack " 412 Precondition Failed\r\n"-responseMessage 413 = P.pack " 413 Request Entity Too Large\r\n"-responseMessage 414 = P.pack " 414 Request-URI Too Large\r\n"-responseMessage 415 = P.pack " 415 Unsupported Media Type\r\n"-responseMessage 416 = P.pack " 416 Requested range not satisfiable\r\n"-responseMessage 417 = P.pack " 417 Expectation Failed\r\n"-responseMessage 500 = P.pack " 500 Internal Server Error\r\n"-responseMessage 501 = P.pack " 501 Not Implemented\r\n"-responseMessage 502 = P.pack " 502 Bad Gateway\r\n"-responseMessage 503 = P.pack " 503 Service Unavailable\r\n"-responseMessage 504 = P.pack " 504 Gateway Time-out\r\n"-responseMessage 505 = P.pack " 505 HTTP Version not supported\r\n"-responseMessage x   = P.pack (show x ++ "\r\n")-
− src/Happstack/Server/HTTP/LazyLiner.hs 
@@ -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
− src/Happstack/Server/HTTP/Listen.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-}-module Happstack.Server.HTTP.Listen(listen) where--import Happstack.Server.HTTP.Types-import Happstack.Server.HTTP.Handler-import Happstack.Server.HTTP.Socket (acceptLite)-import Control.Exception.Extensible as E-import Control.Concurrent-import Network(PortID(..), listenOn, sClose)-import System.IO-{--#ifndef mingw32_HOST_OS--}-import System.Posix.Signals-{--#endif--}-import System.Log.Logger (Priority(..), logM)-log':: Priority -> String -> IO ()-log' = logM "Happstack.Server.HTTP.Listen"--listen :: Conf -> (Request -> IO Response) -> IO ()-listen conf hand = do-{--#ifndef mingw32_HOST_OS--}-  installHandler openEndedPipe Ignore Nothing-{--#endif--}-  let port' = port conf-  log' NOTICE ("Listening on port " ++ show port')-  s <- listenOn $ PortNumber $ toEnum port'-  let work (h,hn,p) = do -- hSetBuffering h NoBuffering-                         let eh (x::SomeException) = log' ERROR ("HTTP request failed with: "++show x)-                         request conf h (hn,fromIntegral p) hand `E.catch` eh-                         hClose h-  let loop = do acceptLite s >>= forkIO . work-                loop-  let pe e = log' ERROR ("ERROR in accept thread: "++-                                                    show e)-  let infi = loop `catchSome` pe >> infi -- loop `E.catch` pe >> infi-  infi `finally` sClose s-{---#ifndef mingw32_HOST_OS--}-  installHandler openEndedPipe Ignore Nothing-  return ()-{--#endif--}-  where  -- why are these handlers needed?--    catchSome op h = op `E.catches` [-            Handler $ \(e :: ArithException) -> h (toException e),-            Handler $ \(e :: ArrayException) -> h (toException e)-          ]-
− src/Happstack/Server/HTTP/LowLevel.hs 
@@ -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.
− src/Happstack/Server/HTTP/Multipart.hs 
@@ -1,216 +0,0 @@--- #hide---------------------------------------------------------------------------------- |--- Module      :  Happstack.Server.HTTP.Multipart--- Copyright   :  (c) Peter Thiemann 2001,2002---                (c) Bjorn Bringert 2005-2006---                (c) Lemmih 2007--- License     :  BSD-style------ Maintainer  :  lemmih@vo.com--- Stability   :  experimental--- Portability :  xbnon-portable------ Parsing of the multipart format from RFC2046.--- Partly based on code from WASHMail.----------------------------------------------------------------------------------module Happstack.Server.HTTP.Multipart-    (-     -- * Multi-part messages-     MultiPart(..), BodyPart(..), Header-    , parseMultipartBody, hGetMultipartBody-     -- * Headers-    , ContentType(..), ContentTransferEncoding(..)-    , ContentDisposition(..)-    , parseContentType-    , parseContentTransferEncoding-    , parseContentDisposition-    , getContentType-    , getContentTransferEncoding-    , getContentDisposition--    , splitAtEmptyLine-    , splitAtCRLF-    ) where--import Control.Monad-import Data.Int (Int64)-import Data.Maybe-import System.IO (Handle)--import Happstack.Server.HTTP.RFC822Headers--import qualified Data.ByteString.Lazy.Char8 as BS-import Data.ByteString.Lazy.Char8 (ByteString)------- * Multi-part stuff.-----data MultiPart = MultiPart [BodyPart]-               deriving (Show, Read, Eq, Ord)--data BodyPart = BodyPart [Header] ByteString-                deriving (Show, Read, Eq, Ord)---- | Read a multi-part message from a 'ByteString'.-parseMultipartBody :: String -- ^ Boundary-                   -> ByteString -> Maybe MultiPart-parseMultipartBody b s = -    do-    ps <- splitParts (BS.pack b) s-    liftM MultiPart $ mapM parseBodyPart ps---- | Read a multi-part message from a 'Handle'.---   Fails on parse errors.-hGetMultipartBody :: String -- ^ Boundary-                  -> Handle-                  -> IO MultiPart-hGetMultipartBody b h = -    do-    s <- BS.hGetContents h-    case parseMultipartBody b s of-        Nothing -> fail "Error parsing multi-part message"-        Just m  -> return m----parseBodyPart :: ByteString -> Maybe BodyPart-parseBodyPart s =-    do-    (hdr,bdy) <- splitAtEmptyLine s-    hs <- parseM pHeaders "<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-                           ('\n','\r') -> Just (j,2)-                           ('\r','\n') -> Just (j,2)-                           _           -> Just (j,1)--findCRorLF :: ByteString -> Maybe Int64-findCRorLF = BS.findIndex (\c -> c == '\n' || c == '\r')--startsWithCRLF :: ByteString -> Bool-startsWithCRLF s = not (BS.null s) && (c == '\n' || c == '\r')-  where c = BS.index s 0---- | Drop an initial CRLF, if any. If the string is empty, ---   nothing is done. If the string does not start with CRLF,---   the first character is dropped.-dropCRLF :: ByteString -> ByteString-dropCRLF s | BS.null s = BS.empty-           | BS.null (BS.drop 1 s) = BS.empty-           | c0 == '\n' && c1 == '\r' = BS.drop 2 s-           | c0 == '\r' && c1 == '\n' = BS.drop 2 s-           | otherwise = BS.drop 1 s-  where c0 = BS.index s 0-        c1 = BS.index s 1
− src/Happstack/Server/HTTP/RFC822Headers.hs 
@@ -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
− src/Happstack/Server/HTTP/Socket.hs 
@@ -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)-
− src/Happstack/Server/HTTP/SocketTH.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Happstack.Server.HTTP.SocketTH(supportsIPv6) where-import Language.Haskell.TH--import Data.List-import Data.Maybe-import Network.Socket(SockAddr(..))---- find out at compile time if the SockAddr6 / HostAddress6 constructors are available-supportsIPv6 :: Bool-supportsIPv6 = $(let c = "Network.Socket.SockAddrInet6"; d = ''SockAddr in-                 do TyConI (DataD _ _ _ cs _) <- reify d-                    if isJust (find (\(NormalC n _) -> show n == c) cs)-                       then [| True |]-                       else [| False |] )-
− src/Happstack/Server/HTTP/Types.hs 
@@ -1,252 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}--module Happstack.Server.HTTP.Types-    (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..),-     rqURL, mkHeaders,-     getHeader, getHeaderBS, getHeaderUnsafe,-     hasHeader, hasHeaderBS, hasHeaderUnsafe,-     setHeader, setHeaderBS, setHeaderUnsafe,-     addHeader, addHeaderBS, addHeaderUnsafe,-     setRsCode, -- setCookie, setCookies,-     Conf(..), nullConf, result, resultBS,-     redirect, -- redirect_, redirect', redirect'_,-     RsFlags(..), nullRsFlags, noContentLength,-     Version(..), Method(..), Headers, continueHTTP,-     Host, ContentType(..)-    ) where---import qualified Data.Map as M-import Data.Typeable(Typeable)-import Data.Maybe-import qualified Data.ByteString.Char8 as P-import Data.ByteString.Char8 (ByteString,pack)-import qualified Data.ByteString.Lazy.Char8 as L-import Happstack.Server.SURI-import Data.Char (toLower)--import Happstack.Server.HTTP.Multipart ( ContentType(..) )-import Happstack.Server.Cookie-import Data.List-import Text.Show.Functions ()---- | HTTP version-data Version = Version Int Int-             deriving(Read,Eq)--instance Show Version where-  show (Version x y) = (show x) ++ "." ++ (show y)--isHTTP1_1 :: Request -> Bool-isHTTP1_1 rq = case rqVersion rq of Version 1 1 -> True; _ -> False-isHTTP1_0 :: Request -> Bool-isHTTP1_0 rq = case rqVersion rq of Version 1 0 -> True; _ -> False---- | Should the connection be used for further messages after this.--- | isHTTP1_0 && hasKeepAlive || isHTTP1_1 && hasNotConnectionClose-continueHTTP :: Request -> Response -> Bool---continueHTTP rq res = isHTTP1_1 rq && getHeader' connectionC rq /= Just closeC && rsfContentLength (rsFlags res)-continueHTTP rq res = (isHTTP1_0 rq && checkHeaderBS connectionC keepaliveC rq) ||-                      (isHTTP1_1 rq && not (checkHeaderBS connectionC closeC rq)) && rsfContentLength (rsFlags res)---- | HTTP configuration-data Conf = Conf { port      :: Int -- ^ Port for the server to listen on.-                 , validator  :: Maybe (Response -> IO Response)-                 } ---- | Default configuration contains no validator and the port is set to 8000-nullConf :: Conf-nullConf = Conf { port      = 8000-                , validator  = Nothing-                }---- | HTTP request method-data Method  = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT-               deriving(Show,Read,Eq)--data HeaderPair = HeaderPair { hName :: ByteString, hValue :: [ByteString] } deriving (Read,Show)--- | Combined headers.-type Headers = M.Map ByteString HeaderPair -- lowercased name -> (realname, value)------ | Result flags-data RsFlags = RsFlags -    { rsfContentLength :: Bool -- ^ whether a content-length header will be added to the result.-    } deriving(Show,Read,Typeable)---- | Default RsFlags that will include the content-length header-nullRsFlags :: RsFlags-nullRsFlags = RsFlags { rsfContentLength = True }--- | Don't display a Content-Lenght field for the 'Result'.-noContentLength :: Response -> Response-noContentLength res = res { rsFlags = upd } where upd = (rsFlags res) { rsfContentLength = False }--data Input = Input-    { inputValue :: L.ByteString-    , inputFilename :: Maybe String-    , inputContentType :: ContentType-    } deriving (Show,Read,Typeable)--type Host = (String,Int)--data Response  = Response  { rsCode    :: Int,-                             rsHeaders :: Headers,-                             rsFlags   :: RsFlags,-                             rsBody    :: L.ByteString,-                             rsValidator:: Maybe (Response -> IO Response)-                           } deriving (Show,Typeable) --data Request = Request { rqMethod  :: Method,-                         rqPaths   :: [String],-			 rqUri	   :: String,-                         rqQuery   :: String,-                         rqInputs  :: [(String,Input)],-                         rqCookies :: [(String,Cookie)],-                         rqVersion :: Version,-                         rqHeaders :: Headers,-                         rqBody    :: RqBody,-                         rqPeer    :: Host-                       } deriving(Show,Read,Typeable)----- | Converts a Request into a String representing the corresponding URL-rqURL :: Request -> String-rqURL rq = '/':intercalate "/" (rqPaths rq) ++ (rqQuery rq)--class HasHeaders a where -    updateHeaders::(Headers->Headers)->a->a-    headers::a->Headers--instance HasHeaders Response where updateHeaders f rs = rs{rsHeaders=f $ rsHeaders rs}-                                   headers = rsHeaders-instance HasHeaders Request where updateHeaders f rq = rq{rqHeaders = f $ rqHeaders rq} -                                  headers = rqHeaders--instance HasHeaders Headers where updateHeaders f = f-                                  headers = id--newtype RqBody = Body L.ByteString deriving (Read,Show,Typeable)---- | Sets the Response status code to the provided Int and lifts the computation--- into a Monad.-setRsCode :: (Monad m) => Int -> Response -> m Response-setRsCode code rs = return rs {rsCode = code}---- | Takes a list of (key,val) pairs and converts it into Headers.  The--- keys will be converted to lowercase-mkHeaders :: [(String,String)] -> Headers-mkHeaders hdrs-    = M.fromListWith join [ (P.pack (map toLower key), HeaderPair (P.pack key) [P.pack value]) | (key,value) <- hdrs ]-    where join (HeaderPair key vs1) (HeaderPair _ vs2) = HeaderPair key (vs1++vs2)------------------------------------------------------------------- Retrieving header information------------------------------------------------------------------- | Lookup header value. Key is case-insensitive.-getHeader :: HasHeaders r => String -> r -> Maybe ByteString-getHeader = getHeaderBS . pack---- | Lookup header value. Key is a case-insensitive bytestring.-getHeaderBS :: HasHeaders r => ByteString -> r -> Maybe ByteString-getHeaderBS = getHeaderUnsafe . P.map toLower---- | Lookup header value with a case-sensitive key. The key must be lowercase.-getHeaderUnsafe :: HasHeaders r => ByteString -> r -> Maybe ByteString-getHeaderUnsafe key var = listToMaybe =<< fmap hValue (getHeaderUnsafe' key var)---- | Lookup header with a case-sensitive key. The key must be lowercase.-getHeaderUnsafe' :: HasHeaders r => ByteString -> r -> Maybe HeaderPair-getHeaderUnsafe' key = M.lookup key . headers------------------------------------------------------------------- Querying header status------------------------------------------------------------------- | Returns True if the associated key is found in the Headers.  The lookup--- is case insensitive.-hasHeader :: HasHeaders r => String -> r -> Bool-hasHeader key r = isJust (getHeader key r)---- | Acts as 'hasHeader' with ByteStrings-hasHeaderBS :: HasHeaders r => ByteString -> r -> Bool-hasHeaderBS key r = isJust (getHeaderBS key r)---- | Acts as 'hasHeaderBS' but the key is case sensitive.  It should be--- in lowercase.-hasHeaderUnsafe :: HasHeaders r => ByteString -> r -> Bool-hasHeaderUnsafe key r = isJust (getHeaderUnsafe' key r)--checkHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> Bool-checkHeaderBS key val = checkHeaderUnsafe (P.map toLower key) (P.map toLower val)--checkHeaderUnsafe :: HasHeaders r => ByteString -> ByteString -> r -> Bool-checkHeaderUnsafe key val r-    = case getHeaderUnsafe key r of-        Just val' | P.map toLower val' == val -> True-        _ -> False-------------------------------------------------------------------- Setting header status------------------------------------------------------------------- | Associates the key/value pair in the headers.  Forces the key to be--- lowercase.-setHeader :: HasHeaders r => String -> String -> r -> r-setHeader key val = setHeaderBS (pack key) (pack val)---- | Acts as 'setHeader' but with ByteStrings.-setHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r-setHeaderBS key val = setHeaderUnsafe (P.map toLower key) (HeaderPair key [val])---- | Sets the key to the HeaderPair.  This is the only way to associate a key--- with multiple values via the setHeader* functions.  Does not force the key--- to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. -setHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r-setHeaderUnsafe key val = updateHeaders (M.insert key val)------------------------------------------------------------------- Adding headers------------------------------------------------------------------- | Add a key/value pair to the header.  If the key already has a value--- associated with it, then the value will be appended.  --- Forces the key to be lowercase.-addHeader :: HasHeaders r => String -> String -> r -> r-addHeader key val = addHeaderBS (pack key) (pack val)---- | Acts as addHeader except for ByteStrings-addHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r-addHeaderBS key val = addHeaderUnsafe (P.map toLower key) (HeaderPair key [val])---- | Add a key/value pair to the header using the underlying HeaderPair data--- type.  Does not force the key to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. -addHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r-addHeaderUnsafe key val = updateHeaders (M.insertWith join key val)-    where join (HeaderPair k vs1) (HeaderPair _ vs2) = HeaderPair k (vs1++vs2)---- | Creates a Response with the given Int as the status code and the provided--- String as the body of the Response -result :: Int -> String -> Response-result code = resultBS code . L.pack---- | Acts as 'result' but works with ByteStrings directly.-resultBS :: Int -> L.ByteString -> Response-resultBS code s = Response code M.empty nullRsFlags s Nothing---- | Sets the Response's status code to the given Int and redirects to the given URI-redirect :: (ToSURI s) => Int -> s -> Response -> Response-redirect c s resp = setHeaderBS locationC (pack (render (toSURI s))) resp{rsCode = c}---- constants here-locationC :: ByteString-locationC   = P.pack "Location"-closeC :: ByteString-closeC      = P.pack "close"-connectionC :: ByteString-connectionC = P.pack "Connection"-keepaliveC :: ByteString-keepaliveC  = P.pack "Keep-Alive"-
− src/Happstack/Server/HTTPClient/HTTP.hs 
@@ -1,1019 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}--------------------------------------------------------------------------------- |--- Module      :  Happstack.Server.HTTPClient.HTTP--- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2005--- License     :  BSD--- --- Maintainer  :  bjorn@bringert.net--- Stability   :  experimental--- Portability :  non-portable (not tested)------ An easy HTTP interface enjoy.------ * Changes by Simon Foster:---      - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules---      - Created functions receiveHTTP and responseHTTP to allow server side interactions---        (although 100-continue is unsupported and I haven't checked for standard compliancy).---      - Pulled the transfer functions from sendHTTP to global scope to allow access by---        above functions.------ * Changes by Graham Klyne:---      - export httpVersion---      - use new URI module (similar to old, but uses revised URI datatype)------ * Changes by Bjorn Bringert:------      - handle URIs with a port number---      - added debugging toggle---      - disabled 100-continue transfers to get HTTP\/1.0 compatibility---      - change 'ioError' to 'throw'---      - Added simpleHTTP_, which takes a stream argument.------ * Changes from 0.1---      - change 'openHTTP' to 'openTCP', removed 'closeTCP' - use 'close' from 'Stream' class.---      - added use of inet_addr to openHTTP, allowing use of IP "dot" notation addresses.---      - reworking of the use of Stream, including alterations to make 'sendHTTP' generic---        and the addition of a debugging stream.---      - simplified error handling.--- --- * TODO---     - request pipelining---     - https upgrade (includes full TLS, i.e. SSL, implementation)---         - use of Stream classes will pay off---         - consider C implementation of encryption\/decryption---     - comm timeouts---     - MIME & entity stuff (happening in separate module)---     - support \"*\" uri-request-string for OPTIONS request method--- --- --- * Header notes:------     [@Host@]---                  Required by HTTP\/1.1, if not supplied as part---                  of a request a default Host value is extracted---                  from the request-uri.--- ---     [@Connection@] ---                  If this header is present in any request or---                  response, and it's value is "close", then---                  the current request\/response is the last ---                  to be allowed on that connection.--- ---     [@Expect@]---                  Should a request contain a body, an Expect---                  header will be added to the request.  The added---                  header has the value \"100-continue\".  After---                  a 417 \"Expectation Failed\" response the request---                  is attempted again without this added Expect---                  header.---                  ---     [@TransferEncoding,ContentLength,...@]---                  if request is inconsistent with any of these---                  header values then you may not receive any response---                  or will generate an error response (probably 4xx).--------- * Response code notes--- Some response codes induce special behaviour:------   [@1xx@]   \"100 Continue\" will cause any unsent request body to be sent.---             \"101 Upgrade\" will be returned.---             Other 1xx responses are ignored.--- ---   [@417@]   The reason for this code is \"Expectation failed\", indicating---             that the server did not like the Expect \"100-continue\" header---             added to a request.  Receipt of 417 will induce another---             request attempt (without Expect header), unless no Expect header---             had been added (in which case 417 response is returned).----------------------------------------------------------------------------------module Happstack.Server.HTTPClient.HTTP (-    module Happstack.Server.HTTPClient.Stream,-    module Happstack.Server.HTTPClient.TCP,--    -- ** Constants-    httpVersion,-    -    -- ** HTTP -    Request(..),-    Response(..),-    RequestMethod(..),-    simpleHTTP, simpleHTTP_,-    sendHTTP,-    sendHTTPPipelined,-    receiveHTTP,-    respondHTTP,--    -- ** Header Functions-    HasHeaders,-    Header(..),-    HeaderName(..),-    insertHeader,-    insertHeaderIfMissing,-    insertHeaders,-    retrieveHeaders,-    replaceHeader,-    findHeader,--    -- ** URL Encoding-    urlEncode,-    urlDecode,-    urlEncodeVars,--) where---------------------------------------------------------------------------------------- Imports ----------------------------------------------------------------------------------------------------------import Control.Exception.Extensible as Exception---- Networking-import Network.URI-import Happstack.Server.HTTPClient.Stream-import Happstack.Server.HTTPClient.TCP----- Util-import Data.Bits ((.&.))-import Data.Char-import Data.List (partition,elemIndex,intersperse)-import Data.Maybe-import Control.Monad (when,forM)-import Numeric (readHex)-import Text.ParserCombinators.ReadP-import System.IO------ Turn on to enable HTTP traffic logging-debug :: Bool-debug = True -- False---- File that HTTP traffic logs go to-httpLogFile :: String-httpLogFile = "http-debug.log"-------------------------------------------------------------------------------------- Misc --------------------------------------------------------------------------------------------------------------- remove leading and trailing whitespace.-trim :: String -> String-trim = let dropspace = dropWhile isSpace in-       reverse . dropspace . reverse . dropspace----- Split a list into two parts, the delimiter occurs--- at the head of the second list.  Nothing is returned--- when no occurance of the delimiter is found.-split :: Eq a => a -> [a] -> Maybe ([a],[a])-split delim list = case delim `elemIndex` list of-    Nothing -> Nothing-    Just x  -> Just $ splitAt x list-    ---crlf :: String-crlf = "\r\n"-sp :: String-sp   = " "-------------------------------------------------------------------------------------- Header Data --------------------------------------------------------------------------------------------------------- | The Header data type pairs header names & values.-data Header = Header HeaderName String---instance Show Header where-    show (Header key value) = show key ++ ": " ++ value ++ crlf----- | HTTP Header Name type:---  Why include this at all?  I have some reasons---   1) prevent spelling errors of header names,---   2) remind everyone of what headers are available,---   3) might speed up searches for specific headers.------  Arguments against:---   1) makes customising header names laborious---   2) increases code volume.----data HeaderName = -                 -- Generic Headers ---                  HdrCacheControl-                | HdrConnection-                | HdrDate-                | HdrPragma-                | HdrTransferEncoding        -                | HdrUpgrade                -                | HdrVia--                -- Request Headers ---                | HdrAccept-                | HdrAcceptCharset-                | HdrAcceptEncoding-                | HdrAcceptLanguage-                | HdrAuthorization-                | HdrCookie-                | HdrExpect-                | HdrFrom-                | HdrHost-                | HdrIfModifiedSince-                | HdrIfMatch-                | HdrIfNoneMatch-                | HdrIfRange-                | HdrIfUnmodifiedSince-                | HdrMaxForwards-                | HdrProxyAuthorization-                | HdrRange-                | HdrReferer-                | HdrUserAgent--                -- Response Headers-                | HdrAge-                | HdrLocation-                | HdrProxyAuthenticate-                | HdrPublic-                | HdrRetryAfter-                | HdrServer-                | HdrSetCookie-                | HdrVary-                | HdrWarning-                | HdrWWWAuthenticate--                -- Entity Headers-                | HdrAllow-                | HdrContentBase-                | HdrContentEncoding-                | HdrContentLanguage-                | HdrContentLength-                | HdrContentLocation-                | HdrContentMD5-                | HdrContentRange-                | HdrContentType-                | HdrETag-                | HdrExpires-                | HdrLastModified--                -- Mime entity headers (for sub-parts)-                | HdrContentTransferEncoding--                -- | Allows for unrecognised or experimental headers.-                | HdrCustom String -- not in header map below.-    deriving(Eq)----- Translation between header names and values,--- good candidate for improvement.-headerMap :: [ (String,HeaderName) ]-headerMap - = [  ("Cache-Control"        ,HdrCacheControl      )-	, ("Connection"           ,HdrConnection        )-	, ("Date"                 ,HdrDate              )    -	, ("Pragma"               ,HdrPragma            )-	, ("Transfer-Encoding"    ,HdrTransferEncoding  )        -	, ("Upgrade"              ,HdrUpgrade           )                -	, ("Via"                  ,HdrVia               )-	, ("Accept"               ,HdrAccept            )-	, ("Accept-Charset"       ,HdrAcceptCharset     )-	, ("Accept-Encoding"      ,HdrAcceptEncoding    )-	, ("Accept-Language"      ,HdrAcceptLanguage    )-	, ("Authorization"        ,HdrAuthorization     )-	, ("From"                 ,HdrFrom              )-	, ("Host"                 ,HdrHost              )-	, ("If-Modified-Since"    ,HdrIfModifiedSince   )-	, ("If-Match"             ,HdrIfMatch           )-	, ("If-None-Match"        ,HdrIfNoneMatch       )-	, ("If-Range"             ,HdrIfRange           ) -	, ("If-Unmodified-Since"  ,HdrIfUnmodifiedSince )-	, ("Max-Forwards"         ,HdrMaxForwards       )-	, ("Proxy-Authorization"  ,HdrProxyAuthorization)-	, ("Range"                ,HdrRange             )   -	, ("Referer"              ,HdrReferer           )-	, ("User-Agent"           ,HdrUserAgent         )-	, ("Age"                  ,HdrAge               )-	, ("Location"             ,HdrLocation          )-	, ("Proxy-Authenticate"   ,HdrProxyAuthenticate )-	, ("Public"               ,HdrPublic            )-	, ("Retry-After"          ,HdrRetryAfter        )-	, ("Server"               ,HdrServer            )-	, ("Vary"                 ,HdrVary              )-	, ("Warning"              ,HdrWarning           )-	, ("WWW-Authenticate"     ,HdrWWWAuthenticate   )-	, ("Allow"                ,HdrAllow             )-	, ("Content-Base"         ,HdrContentBase       )-	, ("Content-Encoding"     ,HdrContentEncoding   )-	, ("Content-Language"     ,HdrContentLanguage   )-	, ("Content-Length"       ,HdrContentLength     )-	, ("Content-Location"     ,HdrContentLocation   )-	, ("Content-MD5"          ,HdrContentMD5        )-	, ("Content-Range"        ,HdrContentRange      )-	, ("Content-Type"         ,HdrContentType       )-	, ("ETag"                 ,HdrETag              )-	, ("Expires"              ,HdrExpires           )-	, ("Last-Modified"        ,HdrLastModified      )-   	, ("Set-Cookie"           ,HdrSetCookie         )-	, ("Cookie"               ,HdrCookie            )-    , ("Expect"               ,HdrExpect            ) ]---instance Show HeaderName where-    show (HdrCustom s) = s-    show x = case filter ((==x).snd) headerMap of-                [] -> error "headerMap incomplete"-                (h:_) -> fst h-------- | This class allows us to write generic header manipulation functions--- for both 'Request' and 'Response' data types.-class HasHeaders x where-    getHeaders :: x -> [Header]-    setHeaders :: x -> [Header] -> x------ Header manipulation functions-insertHeader, replaceHeader, insertHeaderIfMissing-    :: HasHeaders a => HeaderName -> String -> a -> a----- | Inserts a header with the given name and value.--- Allows duplicate header names.-insertHeader name value x = setHeaders x newHeaders-    where-        newHeaders = (Header name value) : getHeaders x----- | Adds the new header only if no previous header shares--- the same name.-insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x)-    where-        newHeaders list@(h@(Header n _): rest)-            | n == name  = list-            | otherwise  = h : newHeaders rest-        newHeaders [] = [Header name value]--            ---- | Removes old headers with duplicate name.-replaceHeader name value x = setHeaders x newHeaders-    where-        newHeaders = Header name value : [ h | h@(Header n _) <- getHeaders x, name /= n ]-          ---- | Inserts multiple headers.-insertHeaders :: HasHeaders a => [Header] -> a -> a-insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs)----- | Gets a list of headers with a particular 'HeaderName'.-retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header]-retrieveHeaders name x = filter matchname (getHeaders x)-    where-        matchname (Header n _)  |  n == name  =  True-        matchname _ = False----- | Lookup presence of specific HeaderName in a list of Headers--- Returns the value from the first matching header.-findHeader :: HasHeaders a => HeaderName -> a -> Maybe String-findHeader n = lookupHeader n . getHeaders---- An anomally really:-lookupHeader :: HeaderName -> [Header] -> Maybe String-lookupHeader v (Header n s:t)  |  v == n   =  Just s-                               | otherwise =  lookupHeader v t-lookupHeader _ _  =  Nothing---------------------------------------------------------------------------------------- HTTP Messages ------------------------------------------------------------------------------------------------------- Protocol version-httpVersion :: String-httpVersion = "HTTP/1.1"----- | The HTTP request method, to be used in the 'Request' object.--- We are missing a few of the stranger methods, but these are--- not really necessary until we add full TLS.-data RequestMethod = HEAD | PUT | GET | POST | OPTIONS | TRACE | DELETE-    deriving(Show,Eq)--rqMethodMap :: [(String, RequestMethod)]-rqMethodMap = [("HEAD",    HEAD),-	       ("PUT",     PUT),-	       ("GET",     GET),-	       ("POST",    POST),-	       ("OPTIONS", OPTIONS),-	       ("TRACE",   TRACE),-               ("DELETE",  DELETE)]---- | An HTTP Request.--- The 'Show' instance of this type is used for message serialisation,--- which means no body data is output.-data Request =-     Request { rqURI       :: URI   -- ^ might need changing in future-                                    --  1) to support '*' uri in OPTIONS request-                                    --  2) transparent support for both relative-                                    --     & absolute uris, although this should-                                    --     already work (leave scheme & host parts empty).-             , rqMethod    :: RequestMethod             -             , rqHeaders   :: [Header]-             , rqBody      :: String-             }------- Notice that request body is not included,--- this show function is used to serialise--- a request for the transport link, we send--- the body separately where possible.-instance Show Request where-    show (Request u m h _) =-        show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf-        ++ concatMap show h ++ crlf-        where-            alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' -                        then u { uriPath = '/' : uriPath u } -                        else u---instance HasHeaders Request where-    getHeaders = rqHeaders-    setHeaders rq hdrs = rq { rqHeaders=hdrs }-------type ResponseCode  = (Int,Int,Int)-type ResponseData  = (ResponseCode,String,[Header])-type RequestData   = (RequestMethod,URI,[Header])---- | An HTTP Response.--- The 'Show' instance of this type is used for message serialisation,--- which means no body data is output, additionally the output will--- show an HTTP version of 1.1 instead of the actual version returned--- by a server.-data Response =-    Response { rspCode     :: ResponseCode-             , rspReason   :: String-             , rspHeaders  :: [Header]-             , rspBody     :: String-             }-                   ----- This is an invalid representation of a received response, --- since we have made the assumption that all responses are HTTP/1.1-instance Show Response where-    show (Response (a,b,c) reason headers _) =-        httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf-        ++ concatMap show headers ++ crlf----instance HasHeaders Response where-    getHeaders = rspHeaders-    setHeaders rsp hdrs = rsp { rspHeaders=hdrs }-------------------------------------------------------------------------------------- Parsing ----------------------------------------------------------------------------------------------------------parseHeader :: String -> Result Header-parseHeader str =-    case split ':' str of-        Nothing -> Left (ErrorParse $ "Unable to parse header: " ++ str)-        Just (k,v) -> Right $ Header (fn k) (trim $ drop 1 v)-    where-        fn k = case map snd $ filter (match k . fst) headerMap of-                 [] -> (HdrCustom k)-                 (h:_) -> h--        match :: String -> String -> Bool-        match s1 s2 = map toLower s1 == map toLower s2-    --parseHeaders :: [String] -> Result [Header]-parseHeaders = catRslts [] . map (parseHeader . clean) . joinExtended ""-    where-        -- Joins consecutive lines where the second line-        -- begins with ' ' or '\t'.-        joinExtended old (h : t)-            | not (null h) && (head h == ' ' || head h == '\t')-                = joinExtended (old ++ ' ' : tail h) t-            | otherwise = old : joinExtended h t-        joinExtended old [] = [old]--        clean [] = []-        clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t-                    | otherwise = h : clean t--        -- tollerant of errors?  should parse-        -- errors here be reported or ignored?-        -- currently ignored.-        catRslts :: [a] -> [Result a] -> Result [a]-        catRslts list (h:t) = -            case h of-                Left _ -> catRslts list t-                Right v -> catRslts (v:list) t-        catRslts list [] = Right $ reverse list            -        ---- Parsing a request-parseRequestHead :: [String] -> Result RequestData-parseRequestHead [] = Left ErrorClosed-parseRequestHead (com:hdrs) =-    requestCommand com `bindE` \(_version,rqm,uri) ->-    parseHeaders hdrs `bindE` \hdrs' ->-    Right (rqm,uri,hdrs')-    where-        requestCommand line-	    =  case words line of-                _yes@(rqm:uri:version) -> case (parseURIReference uri, lookup rqm rqMethodMap) of-					  (Just u, Just r) -> Right (version,r,u)-					  _                -> Left (ErrorParse $ "Request command line parse failure: " ++ line)-		_no -> if null line-			       then Left ErrorClosed-			       else Left (ErrorParse $ "Request command line parse failure: " ++ line)  ---- Parsing a response-parseResponseHead :: [String] -> Result ResponseData-parseResponseHead [] = Left ErrorClosed-parseResponseHead (sts:hdrs) = -    responseStatus sts `bindE` \(_version,code,reason) ->-    parseHeaders hdrs `bindE` \hdrs' ->-    Right (code,reason,hdrs')-    where--        responseStatus line-            =  case words line of-                _yes@(version:code:reason) -> Right (version,match code,concatMap (++" ") reason)-                _no -> if null line -                    then Left ErrorClosed  -- an assumption-                    else Left (ErrorParse $ "Response status line parse failure: " ++ line)---        match [a,b,c] = (digitToInt a,-                         digitToInt b,-                         digitToInt c)-        match _ = (-1,-1,-1)  -- will create appropriate behaviour---        -------------------------------------------------------------------------------------- HTTP Send / Recv ------------------------------------------------------------------------------------------------------data Behaviour = Continue-               | Retry-               | Done-               | ExpectEntity-               | DieHorribly String------matchResponse :: RequestMethod -> ResponseCode -> Behaviour-matchResponse rqst rsp =-    case rsp of-        (1,0,0) -> Continue-        (1,0,1) -> Done        -- upgrade to TLS-        (1,_,_) -> Continue    -- default-        (2,0,4) -> Done-        (2,0,5) -> Done-        (2,_,_) -> ans-        (3,0,4) -> Done-        (3,0,5) -> Done-        (3,_,_) -> ans-        (4,1,7) -> Retry       -- Expectation failed-        (4,_,_) -> ans-        (5,_,_) -> ans-        (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised")-    where-        ans | rqst == HEAD = Done-            | otherwise    = ExpectEntity-        ---- | Simple way to get a resource across a non-persistant connection.--- Headers that may be altered:---  Host        Altered only if no Host header is supplied, HTTP\/1.1---              requires a Host header.---  Connection  Where no allowance is made for persistant connections---              the Connection header will be set to "close"-simpleHTTP :: Request -> IO (Result Response)-simpleHTTP r = -    do -       auth <- getAuth r-       c <- openTCPPort (uriRegName auth) (port auth)-       simpleHTTP_ c r-    where-        port auth = if null (uriPort auth)-            then 80-            else read $ uriPort auth-            ---- | Like 'simpleHTTP', but acting on an already opened stream.-simpleHTTP_ :: Stream s => s -> Request -> IO (Result Response)-simpleHTTP_ s r =-    do -       auth <- getAuth r-       let r' = fixReq auth r -       rsp <- if debug then do-	        s' <- debugStream httpLogFile s-	        sendHTTP s' r'-	       else-	        sendHTTP s r'-       -- already done by sendHTTP because of "Connection: close" header-       --; close s -       return rsp-       where-  {- RFC 2616, section 5.1.2:-     "The most common form of Request-URI is that used to identify a-      resource on an origin server or gateway. In this case the absolute-      path of the URI MUST be transmitted (see section 3.2.1, abs_path) as-      the Request-URI, and the network location of the URI (authority) MUST-      be transmitted in a Host header field." -}-  -- we assume that this is the case, so we take the host name from-  -- the Host header if there is one, otherwise from the request-URI.-  -- Then we make the request-URI an abs_path and make sure that there-  -- is a Host header.-             fixReq :: URIAuth -> Request -> Request-	     fixReq URIAuth{uriRegName=h} req = -		 insertHeaderIfMissing HdrConnection "close" $-		 insertHeaderIfMissing HdrHost h $-		 req { rqURI = (rqURI req){ uriScheme = "", -					uriAuthority = Nothing } }	       ---- | this is not the most graceful of implementations.--- The problem is that Network.URI.authority is--- deprecated.  And we want to use Network.URI.URIAuth.------ So this method use to parse a "host" field as a URI--- auth, which is not stictly correct.  We still --- fake that behavior here.-getAuth :: Monad m => Request -> m URIAuth-getAuth r = case auth of-			 Just x -> return x -			 Nothing -> fail $ "Error parsing URI authority '"-				           ++ show (rqURI r) ++ "'"-		 where-            auth = case findHeader HdrHost r of-			      Just h -> Just $ fakeAuth h -			      Nothing -> uriAuthority (rqURI r)-            fakeAuth h = fst . head $ (flip readP_to_S) h $ do-                    host<-many1 $ satisfy (\c -> c /= ':')-                    port<-option "" $ char ':' >> many1 get-                    return URIAuth{uriRegName=host, uriPort=port, uriUserInfo=""}---sendHTTP :: Stream s => s -> Request -> IO (Result Response)-sendHTTP conn rq-    = do rst <- sendHTTPPipelined conn [rq]-         case rst of-           ([response],_) -> return (Right response)-           (_,Just err)   -> return (Left err)-           (_,_) -> error "Case not supported in sendHTTP"--sendHTTPPipelined :: Stream s => s -> [Request] -> IO ([Response],Maybe ConnError)-sendHTTPPipelined conn rqs = -    do { (ok,rsp) <- Exception.catch (main (map fixHostHeader rqs))-                      (\(e::SomeException) -> do { close conn; throw e })-       ; let fn list = when (any findConnClose list)-                            (close conn)-       ; fn (map rqHeaders rqs ++ map rspHeaders ok)-       ; return (ok,rsp)-       }-    where       --- From RFC 2616, section 8.2.3:--- 'Because of the presence of older implementations, the protocol allows--- ambiguous situations in which a client may send "Expect: 100---- continue" without receiving either a 417 (Expectation Failed) status--- or a 100 (Continue) status. Therefore, when a client sends this--- header field to an origin server (possibly via a proxy) from which it--- has never seen a 100 (Continue) status, the client SHOULD NOT wait--- for an indefinite period before sending the request body.'------ Since we would wait forever, I have disabled use of 100-continue for now.-        main :: [Request] -> IO ([Response], Maybe ConnError)-        main rqsts =-            do -	       --let str = if null (rqBody rqst)-               --              then show rqst-               --              else show (insertHeader HdrExpect "100-continue" rqst)-	       -- write body immediately, don't wait for 100 CONTINUE-               writeBlock conn $ concat $ intersperse "\r\n" [ show rqst ++ rqBody rqst | rqst <- rqsts ]-               rets <- forM rqsts $ \rqst ->-                       do rsp <- getResponseHead-                          switchResponse True True rsp rqst-               return (sequenceResponses rets)--        sequenceResponses :: [Result Response] -> ([Response], Maybe ConnError)-        sequenceResponses = worker []-            where worker acc [] = (reverse acc, Nothing)-                  worker acc (Right x:xs) = worker (x:acc) xs-                  worker acc (Left x:_) = (reverse acc,Just x)--        -- reads and parses headers-        getResponseHead :: IO (Result ResponseData)-        getResponseHead =-            do { lor <- readTillEmpty1 conn-               ; return $ lor `bindE` parseResponseHead-               }--        -- Hmmm, this could go bad if we keep getting "100 Continue"-        -- responses...  Except this should never happen according-        -- to the RFC.-        switchResponse :: Bool {- allow retry? -}-                       -> Bool {- is body sent? -}-                       -> Result ResponseData-                       -> Request-                       -> IO (Result Response)-            -        switchResponse _ _ (Left e) _ = return (Left e)-                -- retry on connreset?-                -- if we attempt to use the same socket then there is an excellent-                -- chance that the socket is not in a completely closed state.--        switchResponse allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst =-            case matchResponse (rqMethod rqst) cd of-                Continue-                    | not bdy_sent -> {- Time to send the body -}-                        do { val <- writeBlock conn (rqBody rqst)-                           ; case val of-                                Left e -> return (Left e)-                                Right _ ->-                                    do { rsp <- getResponseHead-                                       ; switchResponse allow_retry True rsp rqst-                                       }-                           }-                    | otherwise -> {- keep waiting -}-                        do { rsp <- getResponseHead-                           ; switchResponse allow_retry bdy_sent rsp rqst                           -                           }--                Retry -> {- Request with "Expect" header failed.-                                Trouble is the request contains Expects-                                other than "100-Continue" -}-                    do { writeBlock conn (show rqst ++ rqBody rqst)-                       ; rsp <- getResponseHead-                       ; switchResponse False bdy_sent rsp rqst-                       }   -                     -                Done ->-                    return (Right $ Response cd rn hdrs "")--                DieHorribly str ->-                    return $ Left $ ErrorParse ("Invalid response: " ++ str)--                ExpectEntity ->-                    let tc = lookupHeader HdrTransferEncoding hdrs-                        cl = lookupHeader HdrContentLength hdrs-                    in-                    do { rslt <- case tc of-                          Nothing -> -                              case cl of-                                  Just x  -> linearTransfer conn (read x :: Int)-                                  Nothing -> hopefulTransfer conn ""-                          Just x  -> -                              case map toLower (trim x) of-                                  "chunked" -> chunkedTransfer conn-                                  _         -> uglyDeathTransfer conn-                       ; return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy) -                       }--        -        -- Adds a Host header if one is NOT ALREADY PRESENT-        fixHostHeader :: Request -> Request-        fixHostHeader rq =-            let uri = rqURI rq-                h = fmap uriRegName $ uriAuthority uri-            in case h of-                Just x -> insertHeaderIfMissing HdrHost x rq-                _ -> rq-                                     -        -- Looks for a "Connection" header with the value "close".-        -- Returns True when this is found.-        findConnClose :: [Header] -> Bool-        findConnClose hdrs =-            case lookupHeader HdrConnection hdrs of-                Nothing -> False-                Just x  -> map toLower (trim x) == "close"---- | Receive and parse a HTTP request from the given Stream. Should be used ---   for server side interactions.-receiveHTTP :: Stream s => s -> IO (Result Request)-receiveHTTP conn = do rq <- getRequestHead-		      processRequest rq	    -    where-        -- reads and parses headers-        getRequestHead :: IO (Result RequestData)-        getRequestHead =-            do { lor <- readTillEmpty1 conn-               ; return $ lor `bindE` parseRequestHead-               }-	-        processRequest (Left e) = return $ Left e-	processRequest (Right (rm,uri,hdrs)) = -	    do -- FIXME : Also handle 100-continue.-               let tc = lookupHeader HdrTransferEncoding hdrs-                   cl = lookupHeader HdrContentLength hdrs-	       rslt <- case tc of-                          Nothing ->-                              case cl of-                                  Just x  -> linearTransfer conn (read x :: Int)-                                  Nothing -> return (Right ([], "")) -- hopefulTransfer ""-                          Just x  ->-                              case map toLower (trim x) of-                                  "chunked" -> chunkedTransfer conn-                                  _         -> uglyDeathTransfer conn-               -               return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)----- | Very simple function, send a HTTP response over the given stream. This ---   could be improved on to use different transfer types.-respondHTTP :: Stream s => s -> Response -> IO ()-respondHTTP conn rsp = do writeBlock conn (show rsp)-                          -- write body immediately, don't wait for 100 CONTINUE-                          writeBlock conn (rspBody rsp)-			  return ()---- The following functions were in the where clause of sendHTTP, they have--- been moved to global scope so other functions can access them.		       ---- | Used when we know exactly how many bytes to expect.-linearTransfer :: Stream s => s -> Int -> IO (Result ([Header],String))-linearTransfer conn n-    = do info <- readBlock conn n-         return $ info `bindE` \str -> Right ([],str)---- | Used when nothing about data is known,---   Unfortunately waiting for a socket closure---   causes bad behaviour.  Here we just---   take data once and give up the rest.-hopefulTransfer :: Stream s => s -> String -> IO (Result ([Header],String))-hopefulTransfer conn str-    = readLine conn >>= -      either (\v -> return $ Left v)-             (\more -> if null more -                         then return (Right ([],str)) -                         else hopefulTransfer conn (str++more))--- | A necessary feature of HTTP\/1.1---   Also the only transfer variety likely to---   return any footers.-chunkedTransfer :: Stream s => s -> IO (Result ([Header],String))-chunkedTransfer conn-    =  chunkedTransferC conn 0 >>= \v ->-       return $ v `bindE` \(ftrs,c,info) ->-                let myftrs = Header HdrContentLength (show c) : ftrs              -                in Right (myftrs,info)--chunkedTransferC :: Stream s => s -> Int -> IO (Result ([Header],Int,String))-chunkedTransferC conn n-    =  readLine conn >>= \v -> case v of-                  Left e -> return (Left e)-                  Right line ->-                      let size = ( if null line || (head line) == '0'-                                     then 0-                                     else case readHex line of-                                        (n',_):_ -> n'-                                        _       -> 0-                                     )-                      in if size == 0-                           then do { rs <- readTillEmpty2 conn []-                                   ; return $-                                        rs `bindE` \strs ->-                                        parseHeaders strs `bindE` \ftrs ->-                                        Right (ftrs,n,"")-                                   }-                           else do { some <- readBlock conn size-                                   ; readLine conn-                                   ; more <- chunkedTransferC conn (n+size)-                                   ; return $ -                                        some `bindE` \cdata ->-                                        more `bindE` \(ftrs,m,mdata) -> -                                        Right (ftrs,m,cdata++mdata) -                                   }                   ---- | Maybe in the future we will have a sensible thing---   to do here, at that time we might want to change---   the name.-uglyDeathTransfer :: Stream s => s -> IO (Result ([Header],String))-uglyDeathTransfer _-    = return $ Left $ ErrorParse "Unknown Transfer-Encoding"---- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)-readTillEmpty1 :: Stream s => s -> IO (Result [String])-readTillEmpty1 conn =-    do { line <- readLine conn-       ; case line of-           Left e -> return $ Left e-           Right s ->-               if s == crlf-                 then readTillEmpty1 conn-                 else readTillEmpty2 conn [s]-       }---- | Read lines until an empty line (CRLF),---   also accepts a connection close as end of---   input, which is not an HTTP\/1.1 compliant---   thing to do - so probably indicates an---   error condition.-readTillEmpty2 :: Stream s => s -> [String] -> IO (Result [String])-readTillEmpty2 conn list =-    do { line <- readLine conn-       ; case line of-           Left e -> return $ Left e-           Right s ->-               if s == crlf || null s-                 then return (Right $ reverse (s:list))-                 else readTillEmpty2 conn (s:list)-       }--        ------------------------------------------------------------------------------------- A little friendly funtionality ------------------------------------------------------------------------------------{--    I had a quick look around but couldn't find any RFC about-    the encoding of data on the query string.  I did find an-    IETF memo, however, so this is how I justify the urlEncode-    and urlDecode methods.--    Doc name: draft-tiwari-appl-wxxx-forms-01.txt  (look on www.ietf.org)--    Reserved chars:  ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved.-    Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`"-    URI delims: "<" | ">" | "#" | "%" | <">-    Unallowed ASCII: <US-ASCII coded characters 00-1F and 7F hexadecimal>-                     <US-ASCII coded character 20 hexadecimal>-    Also unallowed:  any non-us-ascii character--    Escape method: char -> '%' a b  where a, b :: Hex digits--}--urlEncode, urlDecode :: String -> String--urlDecode ('%':a:b:rest) = chr (16 * digitToInt a + digitToInt b)-                         : urlDecode rest-urlDecode (h:t) = h : urlDecode t-urlDecode [] = []--urlEncode (h:t) =-    let str = if reserved_ (ord h) then escape h else [h]-    in str ++ urlEncode t-    where-        reserved_ x-            | x >= ord 'a' && x <= ord 'z' = False-            | x >= ord 'A' && x <= ord 'Z' = False-            | x >= ord '0' && x <= ord '9' = False-            | x <= 0x20 || x >= 0x7F = True-            | otherwise = x `elem` map ord [';','/','?',':','@','&'-                                           ,'=','+',',','$','{','}'-                                           ,'|','\\','^','[',']','`'-                                           ,'<','>','#','%','"']-        -- wouldn't it be nice if the compiler-        -- optimised the above for us?--        escape x = -            let y = ord x -            in [ '%', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ]--urlEncode [] = []-            ----- Encode form variables, useable in either the--- query part of a URI, or the body of a POST request.--- I have no source for this information except experience,--- this sort of encoding worked fine in CGI programming.-urlEncodeVars :: [(String,String)] -> String-urlEncodeVars ((n,v):t) =-    let (same,diff) = partition ((==n) . fst) t-    in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same)-       ++ urlEncodeRest diff-       where urlEncodeRest [] = []-             urlEncodeRest diff = '&' : urlEncodeVars diff-urlEncodeVars [] = []
− src/Happstack/Server/HTTPClient/Stream.hs 
@@ -1,173 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Happstack.Server.HTTPClient.Stream--- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004--- License     :  BSD------ Maintainer  :  bjorn@bringert.net--- Stability   :  experimental--- Portability :  non-portable (not tested)------ An library for creating abstract streams. Originally part of Gray's\/Bringert's--- HTTP module.------ * Changes by Simon Foster:---      - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules---      -------------------------------------------------------------------------------module Happstack.Server.HTTPClient.Stream (-    -- ** Streams-    Debug,-    Stream(..),-    debugStream,-    -    -- ** Errors-    ConnError(..),-    Result,-    handleSocketError,-    bindE,-    myrecv--) where--import Control.Exception.Extensible as Exception-import System.IO.Error---- Networking-import Network.Socket--import Control.Monad (liftM)-import System.IO--data ConnError = ErrorReset -               | ErrorClosed-               | ErrorParse String-               | ErrorMisc String-    deriving(Show,Eq)---- error propagating:--- we could've used a monad, but that would lead us--- into using the "-fglasgow-exts" compile flag.-bindE :: Either ConnError a -> (a -> Either ConnError b) -> Either ConnError b-bindE (Left e)  _ = Left e-bindE (Right v) f = f v---- | This is the type returned by many exported network functions.-type Result a = Either ConnError   {- error  -}-                       a           {- result -}-------------------------------------------------------------------------------------- Gentle Art of Socket Sucking --------------------------------------------------------------------------------------- | Streams should make layering of TLS protocol easier in future,--- they allow reading/writing to files etc for debugging,--- they allow use of protocols other than TCP/IP--- and they allow customisation.------ Instances of this class should not trim--- the input in any way, e.g. leave LF on line--- endings etc. Unless that is exactly the behaviour--- you want from your twisted instances ;)-class Stream x where -    readLine   :: x -> IO (Result String)-    readBlock  :: x -> Int -> IO (Result String)-    writeBlock :: x -> String -> IO (Result ())-    close      :: x -> IO ()-------- Exception handler for socket operations-handleSocketError :: Socket -> Exception.SomeException -> IO (Result a)-handleSocketError sk e =-    do { se <- getSocketOption sk SoError-       ; if se == 0-            then throw e-            else return $ if se == 10054       -- reset-                then Left ErrorReset-                else Left $ ErrorMisc $ show se-       }-----instance Stream Socket where-    readBlock sk n = (liftM Right $ fn n) `Exception.catch` (handleSocketError sk)-        where-            fn x = do { str <- myrecv sk x-                      ; let len = length str-                      ; if len < x && len /= 0-                          then ( fn (x-len) >>= \more -> return (str++more) )                        -                          else return str-                      }--    -- Use of the following function is discouraged.-    -- The function reads in one character at a time, -    -- which causes many calls to the kernel recv()-    -- hence causes many context switches.-    readLine sk = (liftM Right $ fn "") `Exception.catch` (handleSocketError sk)-            where-                fn str =-                    do { c <- myrecv sk 1 -- like eating through a straw.-                       ; if null c || c == "\n"-                           then return (reverse str++c)-                           else fn (head c:str)-                       }-    -    writeBlock sk str = (liftM Right $ fn str) `Exception.catch` (handleSocketError sk)-        where-            fn [] = return ()-            fn x  = send sk x >>= \i -> fn (drop i x)--    -- This slams closed the connection (which is considered rude for TCP\/IP)-    close sk = shutdown sk ShutdownBoth >> sClose sk--myrecv :: Socket -> Int -> IO String-myrecv sock len =-    let handler e = if isEOFError e then return [] else ioError e-        in System.IO.Error.catch (recv sock len) handler---- | Allows stream logging.--- Refer to 'debugStream' below.-data Debug x = Dbg Handle x---instance (Stream x) => Stream (Debug x) where-    readBlock (Dbg h c) n =-        do { val <- readBlock c n-           ; hPutStrLn h ("readBlock " ++ show n ++ ' ' : show val)-           ; hFlush h-           ; return val-           }--    readLine (Dbg h c) =-        do { val <- readLine c-           ; hPutStrLn h ("readLine " ++ show val)-           ; return val-           }--    writeBlock (Dbg h c) str =-        do { val <- writeBlock c str-           ; hPutStrLn h ("writeBlock " ++ show val ++ ' ' : show str)-           ; return val-           }--    close (Dbg h c) =-        do { hPutStrLn h "closing..."-           ; hFlush h-           ; close c-           ; hPutStrLn h "...closed"-           ; hClose h-           }----- | Wraps a stream with logging I\/O, the first--- argument is a filename which is opened in AppendMode.-debugStream :: (Stream a) => String -> a -> IO (Debug a)-debugStream file stm = -    do { h <- openFile file AppendMode-       ; hPutStrLn h "File opened for appending."-       ; return (Dbg h stm)-       }
− src/Happstack/Server/HTTPClient/TCP.hs 
@@ -1,193 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}--------------------------------------------------------------------------------- |--- Module      :  Happstack.Server.HTTPClient.TCP--- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004--- License     :  BSD------ Maintainer  :  bjorn@bringert.net--- Stability   :  experimental--- Portability :  non-portable (not tested)------ An easy access TCP library. Makes the use of TCP in Haskell much easier.--- This was originally part of Gray's\/Bringert's HTTP module.------ * Changes by Simon Foster:---      - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules---      -------------------------------------------------------------------------------module Happstack.Server.HTTPClient.TCP (-    -- ** Connections-    Conn(..),-    Connection(..),-    openTCP,-    openTCPPort,-    isConnectedTo-) where--import Control.Exception.Extensible as Exception---- Networking-import Network.BSD-import Network.Socket-import Happstack.Server.HTTPClient.Stream--import Data.List (elemIndex)-import Data.Char-import Data.IORef-import System.IO-------------------------------------------------------------------------------------- TCP Connections ---------------------------------------------------------------------------------------------------- | The 'Connection' newtype is a wrapper that allows us to make--- connections an instance of the StreamIn\/Out classes, without ghc extensions.--- While this looks sort of like a generic reference to the transport--- layer it is actually TCP specific, which can be seen in the--- implementation of the 'Stream Connection' instance.-newtype Connection = ConnRef {getRef :: IORef Conn}----- | The 'Conn' object allows input buffering, and maintenance of --- some admin-type data.-data Conn = MkConn { connSock :: ! Socket-                   , connAddr :: ! SockAddr -                   , connBffr :: ! String -                   , connHost :: String-                   }-          | ConnClosed-    deriving(Eq)----- | Open a connection to port 80 on a remote host.-openTCP :: String -> IO Connection-openTCP host = openTCPPort host 80----- | This function establishes a connection to a remote--- host, it uses "getHostByName" which interrogates the--- DNS system, hence may trigger a network connection.------ Add a "persistant" option?  Current persistant is default.--- Use "Result" type for synchronous exception reporting?-openTCPPort :: String -> Int -> IO Connection-openTCPPort uri port = -    do { s <- socket AF_INET Stream 6-       ; setSocketOption s KeepAlive 1-       ; host <- Exception.catch (inet_addr uri)    -- handles ascii IP numbers-                       (\(_::SomeException) -> getHostByName uri >>= \host -> -- _shrug_ this will catch _any_ exception FIXME-                            case hostAddresses host of-                                [] -> return (error "no addresses in host entry")-                                (h:_) -> return h)-       ; let a = SockAddrInet (toEnum port) host-       ; Exception.catch (connect s a) (\(e::SomeException) -> sClose s >> throw e)-       ; v <- newIORef (MkConn s a [] uri)-       ; return (ConnRef v)-       }--instance Stream Connection where-    readBlock ref n = -        readIORef (getRef ref) >>= \conn -> case conn of-            ConnClosed -> return (Left ErrorClosed)-            (MkConn sk _addr bfr _hst)-                | length bfr >= n ->-                    do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop n bfr) })-                       ; return (Right $ take n bfr)-                       }-                | otherwise ->-                    do { modifyIORef (getRef ref) (\c -> c { connBffr=[] })-                       ; more <- readBlock sk (n - length bfr)-                       ; return $ case more of-                            Left _ -> more-                            Right s -> (Right $ bfr ++ s)-                       }--    -- This function uses a buffer, at this time the buffer is just 1000 characters.-    -- (however many bytes this is is left to the user to decypher)-    readLine ref =-        readIORef (getRef ref) >>= \conn -> case conn of-             ConnClosed -> return (Left ErrorClosed)-             (MkConn sk _addr bfr _)-                 | null bfr ->  {- read in buffer -}-                      do { str <- myrecv sk 1000  -- DON'T use "readBlock sk 1000" !!-                                                -- ... since that call will loop.-                         ; let len = length str-                         ; if len == 0   {- indicates a closed connection -}-                              then return (Right "")-                              else modifyIORef (getRef ref) (\c -> c { connBffr=str })-                                   >> readLine ref  -- recursion-                         }-                 | otherwise ->-                      case elemIndex '\n' bfr of-                          Nothing -> {- need recursion to finish line -}-                              do { modifyIORef (getRef ref) (\c -> c { connBffr=[] })-                                 ; more <- readLine ref -- contains extra recursion                      -                                 ; return $ more `bindE` \str -> Right (bfr++str)-                                 }-                          Just i ->    {- end of line found -}-                              let (bgn,end) = splitAt i bfr in-                              do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop 1 end) })-                                 ; return (Right (bgn++['\n']))-                                 }----    -- The 'Connection' object allows no outward buffering, -    -- since in general messages are serialised in their entirety.-    writeBlock ref str =-        readIORef (getRef ref) >>= \conn -> case conn of-            ConnClosed -> return (Left ErrorClosed)-            (MkConn sk addr _ _) -> fn sk addr str `Exception.catch` (handleSocketError sk)-        where-            fn sk addr s-                | null s    = return (Right ())  -- done-                | otherwise =-                    getSocketOption sk SoError >>= \se ->-                    if se == 0-                        then sendTo sk s addr >>= \i -> fn sk addr (drop i s)-                        else writeIORef (getRef ref) ConnClosed >>-                             if se == 10054-                                 then return (Left ErrorReset)-                                 else return (Left $ ErrorMisc $ show se)---    -- Closes a Connection.  Connection will no longer-    -- allow any of the other Stream functions.  Notice that a Connection may close-    -- at any time before a call to this function.  This function is idempotent.-    -- (I think the behaviour here is TCP specific)-    close ref = -        do { c <- readIORef (getRef ref)-           ; closeConn c `Exception.catch` (\(_::SomeException) -> return ()) -- FIXME see above-           ; writeIORef (getRef ref) ConnClosed-           }-        where-            -- Be kind to peer & close gracefully.-            closeConn (ConnClosed) = return ()-            closeConn (MkConn sk _addr [] _) =-                do { shutdown sk ShutdownSend-                   ; suck ref-                   ; shutdown sk ShutdownReceive-                   ; sClose sk-                   }-            closeConn (MkConn _ _ _ _) = error "Case in closeConn not supported"--            suck :: Connection -> IO ()-            suck cn = readLine cn >>= -                      either (\_ -> return ()) -- catch errors & ignore-                             (\x -> if null x then return () else suck cn)---- | Checks both that the underlying Socket is connected--- and that the connection peer matches the given--- host name (which is recorded locally).-isConnectedTo :: Connection -> String -> IO Bool-isConnectedTo conn name =-    do { v <- readIORef (getRef conn)-       ; case v of-            ConnClosed -> return False-            (MkConn sk _ _ h) ->-                if (map toLower h == map toLower name)-                then sIsConnected sk-                else return False-       }-
+ src/Happstack/Server/I18N.hs view
@@ -0,0 +1,52 @@+module Happstack.Server.I18N+     ( acceptLanguage+     , bestLanguage+     ) where++import Control.Arrow ((>>>), first, second)+import Data.Function (on)+import qualified Data.ByteString.Char8 as C+import Data.List     (sortBy)+import Data.Maybe    (fromMaybe)+import Data.Text     as Text (Text, breakOnAll, pack, singleton)+import Happstack.Server.Monads (Happstack, getHeaderM)+import Happstack.Server.Internal.Compression (encodings)+import Text.ParserCombinators.Parsec (parse)++-- TODO: proper Accept-Language parser++-- | parse the 'Accept-Language' header, or [] if not found.+acceptLanguage :: (Happstack m) => m [(Text, Maybe Double)]+acceptLanguage =+    do mAcceptLanguage <- (fmap C.unpack) <$> getHeaderM "Accept-Language"+       case mAcceptLanguage of+         Nothing   -> return []+         (Just al) ->+             case parse encodings al al of+               (Left _) -> return []+               (Right encs) -> return (map (first Text.pack) encs)++-- | deconstruct the 'acceptLanguage' results a return a list of+-- languages sorted by preference in descending order.+--+-- Note: this implementation does not conform to RFC4647+--+-- Among other things, it does not handle wildcards. A proper+-- implementation needs to take a list of available languages.+bestLanguage :: [(Text, Maybe Double)] -> [Text]+bestLanguage range =+    -- is no 'q' param, set 'q' to 1.0+    map (second $ fromMaybe 1)     >>>+    -- sort in descending order+    sortBy (flip compare `on` snd) >>>+    -- remove entries with '*' or q == 0. Removing '*' entries is not+    -- technically correct, but it is the best we can do with out a+    -- list of available languages.+    filter (\(lang, q) -> lang /= (Text.singleton '*') && q > 0)  >>>+    -- lookup fallback (RFC 4647, Section 3.4)+    concatMap (explode . fst) $+    range+    where+      -- | example: "en-us-gb" -> ["en-us-gb","en-us","en"]+      explode :: Text -> [Text]+      explode lang = lang : (reverse $ map fst $ breakOnAll (singleton '-') lang)
+ src/Happstack/Server/Internal/Clock.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS -fno-cse #-}+module Happstack.Server.Internal.Clock+    ( getApproximateTime+    , getApproximatePOSIXTime+    , getApproximateUTCTime+    , formatHttpDate+    ) where++import Control.Concurrent+import Control.Monad+import qualified Data.ByteString.Char8 as B+import Data.IORef+import Data.Time.Clock       (UTCTime)+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)+import Data.Time.Format (formatTime, defaultTimeLocale)+import System.IO.Unsafe++data DateCache = DateCache {+      cachedPOSIXTime :: !(IORef POSIXTime)+    , cachedHttpDate  :: !(IORef B.ByteString)+    }++formatHttpDate :: UTCTime -> String+formatHttpDate = formatTime defaultTimeLocale "%a, %d %b %Y %X GMT"+{-# INLINE formatHttpDate #-}++mkTime :: IO (POSIXTime, B.ByteString)+mkTime =+    do now <- getPOSIXTime+       return (now, B.pack $ formatHttpDate (posixSecondsToUTCTime now))++{-# NOINLINE clock #-}+clock :: DateCache+clock = unsafePerformIO $ do+  (now, httpDate) <- mkTime+  nowRef      <- newIORef now+  httpDateRef <- newIORef httpDate+  let dateCache = (DateCache nowRef httpDateRef)+  void $ forkIO $ updater dateCache+  return dateCache++updater :: DateCache -> IO ()+updater dateCache =+    do threadDelay (10^(6 :: Int)) -- Every second+       (now, httpDate) <- mkTime+       writeIORef (cachedPOSIXTime dateCache) now+       writeIORef (cachedHttpDate  dateCache) httpDate+       updater dateCache++getApproximateTime :: IO B.ByteString+getApproximateTime = readIORef (cachedHttpDate clock)++getApproximatePOSIXTime :: IO POSIXTime+getApproximatePOSIXTime = readIORef (cachedPOSIXTime clock)++getApproximateUTCTime :: IO UTCTime+getApproximateUTCTime = posixSecondsToUTCTime <$> getApproximatePOSIXTime
+ src/Happstack/Server/Internal/Compression.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE CPP,NoMonomorphismRestriction, FlexibleContexts #-}+-- | Filter for compressing the 'Response' body.+module Happstack.Server.Internal.Compression+    ( compressedResponseFilter+    , compressedResponseFilter'+    , compressWithFilter+    , gzipFilter+    , deflateFilter+    , identityFilter+    , starFilter+    , encodings+    , standardEncodingHandlers+    ) where+import Happstack.Server.SimpleHTTP+import Text.ParserCombinators.Parsec+import Control.Monad+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif+import Data.Maybe+import Data.List+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Codec.Compression.GZip as GZ+import qualified Codec.Compression.Zlib as Z++-- | reads the @Accept-Encoding@ header.  Then, if possible+-- will compress the response body with methods @gzip@ or @deflate@.+--+-- This function uses 'standardEncodingHandlers'. If you want to+-- provide alternative handers (perhaps to change compression levels),+-- see 'compressedResponseFilter''+--+-- > main =+-- >   simpleHTTP nullConf $+-- >      do str <- compressedResponseFilter+-- >         return $ toResponse ("This response compressed using: " ++ str)+compressedResponseFilter :: (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m, MonadFail m) =>+                            m String -- ^ name of the encoding chosen+compressedResponseFilter = compressedResponseFilter' standardEncodingHandlers++-- | reads the @Accept-Encoding@ header.  Then, if possible+-- will compress the response body using one of the supplied filters.+--+-- A filter function takes two arguments. The first is a 'String' with+-- the value to be used as the 'Content-Encoding' header. The second+-- is 'Bool' which indicates if the compression filter is allowed to+-- fallback to @identity@.+--+-- This is important if the resource being sent using sendfile, since+-- sendfile does not provide a compression option. If @identity@ is+-- allowed, then the file can be sent uncompressed using sendfile. But+-- if @identity@ is not allowed, then the filter will need to return+-- error 406.+--+-- You should probably always include the @identity@ and @*@ encodings+-- as acceptable.+--+-- > myFilters :: (FilterMonad Response m) => [(String, String -> Bool -> m ()]+-- > myFilters = [ ("gzip"    , gzipFilter)+-- >             , ("identity", identityFilter)+-- >             , ("*"       , starFilter)+-- >             ]+-- >+-- > main =+-- >   simpleHTTP nullConf $+-- >      do let filters =+-- > str <- compressedResponseFilter'+-- >         return $ toResponse ("This response compressed using: " ++ str)+compressedResponseFilter' ::+    (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m, MonadFail m)+    => [(String, String -> Bool -> m ())]  -- ^ compression filter assoc list+    -> m String                            -- ^ name of the encoding chosen+compressedResponseFilter' encodingHandlers = do+    getHeaderM "Accept-Encoding" >>=+        (maybe (return "identity") installHandler)++  where+    badEncoding = "Encoding returned not in the list of known encodings"++    installHandler accept = do+      let eEncoding = bestEncoding (map fst encodingHandlers) $ BS.unpack accept+      (coding, identityAllowed, action) <- case eEncoding of+          Left _ -> do+            setResponseCode 406+            finishWith $ toResponse ""++          Right encs@(a:_) -> return (a+                                     , "identity" `elem` encs+                                     , fromMaybe (\ _ _ -> fail badEncoding)+                                          (lookup a encodingHandlers)+                                     )+          Right [] -> fail badEncoding+      action coding identityAllowed+      return coding++-- | Ignore the @Accept-Encoding@ header in the 'Request' and attempt to compress the body of the response with @gzip@.+--+-- calls 'compressWithFilter' using 'GZ.compress'.+--+-- see also: 'compressedResponseFilter'+gzipFilter::(FilterMonad Response m) =>+            String -- ^ encoding to use for Content-Encoding header+          -> Bool   -- ^ fallback to identity for SendFile+          -> m ()+gzipFilter = compressWithFilter GZ.compress++-- | Ignore the @Accept-Encoding@ header in the 'Request' and attempt compress the body of the response with zlib's+-- @deflate@ method+--+-- calls 'compressWithFilter' using 'Z.compress'.+--+-- see also: 'compressedResponseFilter'+deflateFilter::(FilterMonad Response m) =>+               String -- ^ encoding to use for Content-Encoding header+             -> Bool   -- ^ fallback to identity for SendFile+             -> m ()+deflateFilter = compressWithFilter Z.compress++-- | compression filter for the identity encoding (aka, do nothing)+--+-- see also: 'compressedResponseFilter'+identityFilter :: (FilterMonad Response m) =>+                  String  -- ^ encoding to use for Content-Encoding header+               -> Bool    -- ^ fallback to identity for SendFile (irrelavant for this filter)+               -> m ()+identityFilter = compressWithFilter id++-- | compression filter for the * encoding+--+-- This filter always fails.+starFilter :: (FilterMonad Response m, MonadFail m) =>+              String  -- ^ encoding to use for Content-Encoding header+           -> Bool    -- ^ fallback to identity for SendFile (irrelavant for this filter)+           -> m ()+starFilter _ _ = fail "chose * as content encoding"++-- | Ignore the @Accept-Encoding@ header in the 'Request' and attempt to compress the body of the response using the supplied compressor.+--+-- We can not compress files being transfered using 'SendFile'. If+-- @identity@ is an allowed encoding, then just return the 'Response'+-- unmodified. Otherwise we return @406 Not Acceptable@.+--+-- see also: 'gzipFilter', 'deflateFilter', 'identityFilter', 'starFilter', 'compressedResponseFilter''+compressWithFilter :: (FilterMonad Response m) =>+                      (L.ByteString -> L.ByteString) -- ^ function to compress the body+                   -> String -- ^ encoding to use for Content-Encoding header+                   -> Bool   -- ^ fallback to identity for SendFile+                   -> m ()+compressWithFilter compressor encoding identityAllowed =+    composeFilter $ \r ->+        case r of+          Response{} -> setHeader "Content-Encoding" encoding          $+                        setHeader "Vary"             "Accept-Encoding" $+                         r {rsBody = compressor $ rsBody r}+          _ | identityAllowed -> r+            | otherwise       -> (toResponse "") { rsCode = 406 }++-- | based on the rules describe in rfc2616 sec. 14.3+bestEncoding :: [String] -> String -> Either String [String]+bestEncoding availableEncodings encs = do+        encList<-either (Left . show) (Right) $ parse encodings "" encs+        case acceptable encList of+            [] -> Left "no encoding found"+            a -> Right $ a+    where+        -- first intersect with the list of encodings we know how to deal with at all+        knownEncodings:: [(String,Maybe Double)] -> [(String, Maybe Double)]+        knownEncodings m = intersectBy (\x y->fst x == fst y) m (map (\x -> (x,Nothing)) availableEncodings)+        -- this expands the wildcard, by figuring out if we need to include "identity" in the list+        -- Then it deletes the wildcard entry, drops all the "q=0" entries (which aren't allowed).+        --+        -- note this implementation is a little conservative.  if someone were to specify "*"+        -- without a "q" value, it would be this server is willing to accept any format at all.+        -- We pretty much assume we can't send them /any/ format and that they really+        -- meant just "identity" this seems safe to me.+        knownEncodings':: [(String,Maybe Double)] -> [(String, Maybe Double)]+        knownEncodings' m = filter dropZero $ deleteBy (\(a,_) (b,_)->a==b) ("*",Nothing) $+            case lookup "*" (knownEncodings m) of+                Nothing -> addIdent $ knownEncodings m+                Just (Just a) | a>0 -> addIdent $ knownEncodings m+                              | otherwise -> knownEncodings m+                Just (Nothing) -> addIdent $ knownEncodings m+        dropZero (_, Just a) | a==0      = False+                             | otherwise = True+        dropZero (_, Nothing) = True+        addIdent:: [(String,Maybe Double)] -> [(String, Maybe Double)]+        addIdent m = if isNothing $ lookup "identity" m+            then m ++ [("identity",Nothing)]+            else m+        -- finally we sort the list of available encodings.+        acceptable:: [(String,Maybe Double)] -> [String]+        acceptable l = map fst $ sortBy (flip cmp) $  knownEncodings'  l+        -- let the client choose but break ties with gzip+        encOrder = reverse $ zip (reverse availableEncodings) [1..]+        m0 = maybe (0.0::Double) id+        cmp (s,mI) (t,mJ) | m0 mI == m0 mJ+            = compare (m0 $ lookup s encOrder) (m0 $ lookup t encOrder)+                          | otherwise = compare (m0 mI) (m0 mJ)+++-- | an assoc list of encodings and their corresponding compression+-- functions.+--+-- e.g.+--+-- > [("gzip", gzipFilter), ("identity", identityFilter), ("*",starFilter)]+standardEncodingHandlers :: (FilterMonad Response m, MonadFail m) =>+                            [(String, String -> Bool -> m ())]+standardEncodingHandlers = zip standardEncodings handlers++standardEncodings :: [String]+standardEncodings =+    ["gzip"+    ,"x-gzip"+--    ,"compress" -- as far as I can tell there is no haskell library that supports this+--    ,"x-compress" -- as far as I can tell, there is no haskell library that supports this+    ,"deflate"+    ,"identity"+    ,"*"+    ]++handlers::(FilterMonad Response m, MonadFail m) => [String -> Bool -> m ()]+handlers =+    [ gzipFilter+    , gzipFilter+--    ,compressFilter+--    ,compressFilter+    , deflateFilter+    , identityFilter+    , starFilter+    ]++-- | a parser for the Accept-Encoding header+encodings :: GenParser Char st [(String, Maybe Double)]+encodings = ws >> (encoding1 `sepBy` try sep) >>= (\x -> ws >> eof >> return x)+    where+        ws :: GenParser Char st ()+        ws = many space >> return ()++        sep :: GenParser Char st ()+        sep = do+            ws+            _ <- char ','+            ws++        encoding1 :: GenParser Char st ([Char], Maybe Double)+        encoding1 = do+            encoding <- many1 (alphaNum <|> char '-') <|> string "*"+            ws+            quality<-optionMaybe qual+            return (encoding, fmap read quality)++        qual :: GenParser Char st String+        qual = do+            char ';' >> ws >> char 'q' >> ws >> char '=' >> ws+            q<-float+            return q++        int :: GenParser Char st String+        int = many1 digit++        float :: GenParser Char st String+        float = do+                wholePart<-many1 digit+                fractionalPart<-option "" fraction+                return $ wholePart ++ fractionalPart+            <|>+                do+                fractionalPart<-fraction+                return fractionalPart+        fraction :: GenParser Char st String+        fraction = do+            _ <- char '.'+            fractionalPart<-option "" int+            return $ '.':fractionalPart
+ src/Happstack/Server/Internal/Cookie.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE CPP, DeriveDataTypeable #-}++-- http://tools.ietf.org/html/rfc2109+module Happstack.Server.Internal.Cookie+    ( Cookie(..)+    , CookieLife(..)+    , SameSite(..)+    , calcLife+    , mkCookie+    , mkCookieHeader+    , getCookies+    , getCookie+    , getCookies'+    , getCookie'+    , parseCookies+    , cookiesParser+    )+    where++import Control.Monad+import Control.Monad.Fail (MonadFail)+import qualified Data.ByteString.Char8 as C+import Data.Char             (chr, toLower)+import Data.Data             (Data)+import Data.List             ((\\), intersperse)+import Data.Time.Clock       (UTCTime, addUTCTime, diffUTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Time.Format      (formatTime, defaultTimeLocale)+import Happstack.Server.Internal.Clock (getApproximateUTCTime)+import Network.URI           (escapeURIString)+import Text.ParserCombinators.Parsec hiding (token)+++++-- | a type for HTTP cookies. Usually created using 'mkCookie'.+data Cookie = Cookie+    { cookieVersion :: String+    , cookiePath    :: String+    , cookieDomain  :: String+    , cookieName    :: String+    , cookieValue   :: String+    , secure        :: Bool+    , httpOnly      :: Bool+    , sameSite      :: SameSite+    , partitioned   :: Bool+    } deriving (Show, Eq, Read, Data)++-- | Specify the lifetime of a cookie.+--+-- Note that we always set the max-age and expires headers because+-- internet explorer does not honor max-age. You can specific 'MaxAge'+-- or 'Expires' and the other will be calculated for you. Choose which+-- ever one makes your life easiest.+--+data CookieLife+    = Session         -- ^ session cookie - expires when browser is closed+    | MaxAge Int      -- ^ life time of cookie in seconds+    | Expires UTCTime -- ^ cookie expiration date+    | Expired         -- ^ cookie already expired+      deriving (Eq, Ord, Read, Show)++-- | Options for specifying third party cookie behaviour.+--+-- Note that most or all web clients require the cookie to be secure if "none" is+-- specified.+data SameSite+    = SameSiteLax+    -- ^ The cookie is sent in first party contexts as well as linked requests initiated+    -- from other contexts.+    | SameSiteStrict+    -- ^ The cookie is sent in first party contexts only.+    | SameSiteNone+    -- ^ The cookie is sent in first as well as third party contexts if the cookie is+    -- secure.+    | SameSiteNoValue+    -- ^ The default; used if you do not wish a SameSite attribute present at all.+      deriving (Eq, Ord, Data, Show, Read)++displaySameSite :: SameSite -> String+displaySameSite ss =+  case ss of+    SameSiteLax     -> "SameSite=Lax"+    SameSiteStrict  -> "SameSite=Strict"+    SameSiteNone    -> "SameSite=None"+    SameSiteNoValue -> ""++-- convert 'CookieLife' to the argument needed for calling 'mkCookieHeader'+calcLife :: CookieLife -> IO (Maybe (Int, UTCTime))+calcLife Session = return Nothing+calcLife (MaxAge s) =+          do now <- getApproximateUTCTime+             return (Just (s, addUTCTime (fromIntegral s) now))+calcLife (Expires expirationDate) =+          do now <- getApproximateUTCTime+             return $ Just (round  $ expirationDate `diffUTCTime` now, expirationDate)+calcLife Expired =+          return $ Just (0, posixSecondsToUTCTime 0)+++-- | Creates a cookie with a default version of 1, empty domain, a+-- path of "/", secure == False, httpOnly == False and+-- sameSite == SameSiteNoValue and partitioned = False+--+-- see also: 'addCookie'+mkCookie :: String  -- ^ cookie name+         -> String  -- ^ cookie value+         -> Cookie+mkCookie key val = Cookie "1" "/" "" key val False False SameSiteNoValue False++-- | Set a Cookie in the Result.+-- The values are escaped as per RFC 2109, but some browsers may+-- have buggy support for cookies containing e.g. @\'\"\'@ or @\' \'@.+--+-- Also, it seems that chrome, safari, and other webkit browsers do+-- not like cookies which have double quotes around the domain and+-- reject/ignore the cookie. So, we no longer quote the domain.+--+-- internet explorer does not honor the max-age directive so we set+-- both max-age and expires.+--+-- See 'CookieLife' and 'calcLife' for a convenient way of calculating+-- the first argument to this function.+mkCookieHeader :: Maybe (Int, UTCTime) -> Cookie -> String+mkCookieHeader mLife cookie =+  let+    l =+      [ (,) "Domain="  (cookieDomain cookie)+      , (,) "Max-Age=" (maybe "" (show . max 0 . fst) mLife)+      , (,) "expires=" (maybe "" (formatTime'  . snd) mLife)+      , (,) "Path="    (cookiePath cookie)+      , (,) "Version=" (s cookieVersion)+      ]+    formatTime' =+      formatTime defaultTimeLocale "%a, %d-%b-%Y %X GMT"+    encode =+      escapeURIString+        (\c -> c `elem` (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"))+    s f | f cookie == "" = ""+        | otherwise      = '\"' : (encode $ f cookie) ++ "\""+  in+    concat $ intersperse ";" $+         (cookieName cookie++"="++s cookieValue):[ (k++v) | (k,v) <- l, "" /= v ]+      ++ (if secure   cookie then ["Secure"]   else [])+      ++ (if httpOnly cookie then ["HttpOnly"] else [])+      ++ (if sameSite cookie /= SameSiteNoValue+          then [displaySameSite . sameSite $ cookie] else [])+      ++ (if partitioned cookie then ["Partitioned"] else [])++-- | Not an supported api.  Takes a cookie header and returns+-- either a String error message or an array of parsed cookies+parseCookies :: String -> Either String [Cookie]+parseCookies str = either (Left . show) Right $ parse cookiesParser str str++-- | not a supported api.  A parser for RFC 2109 cookies+cookiesParser :: GenParser Char st [Cookie]+cookiesParser = cookies+    where -- Parsers based on RFC 2109+          cookies = do+            ws+            ver<-option "" $ try (cookie_version >>= (\x -> cookieSep >> return x))+            cookieList<-(cookie_value ver) `sepBy1` try cookieSep+            ws+            eof+            return cookieList+          cookie_value ver = do+            name<-name_parser+            cookieEq+            val<-value+            path<-option "" $ try (cookieSep >> cookie_path)+            domain<-option "" $ try (cookieSep >> cookie_domain)+            return $ Cookie ver path domain (low name) val False False SameSiteNoValue False+          cookie_version = cookie_special "$Version"+          cookie_path = cookie_special "$Path"+          cookie_domain = cookie_special "$Domain"+          cookie_special s = do+            void $ string s+            cookieEq+            value+          cookieSep = ws >> oneOf ",;" >> ws+          cookieEq = ws >> char '=' >> ws+          ws = spaces+          value         = word+          word          = try quoted_string <|> try incomp_token <|> return ""++          -- Parsers based on RFC 2068+          quoted_string = do+            void $ char '"'+            r <-many ((try quotedPair) <|> (oneOf qdtext))+            void $ char '"'+            return r++          -- Custom parsers, incompatible with RFC 2068, but more forgiving ;)+          incomp_token  = many1 $ oneOf ((chars \\ ctl) \\ " \t\";")+          name_parser   = many1 $ oneOf ((chars \\ ctl) \\ "= ;,")++          -- Primitives from RFC 2068+          ctl           = map chr (127:[0..31])+          chars         = map chr [0..127]+          octet         = map chr [0..255]+          text          = octet \\ ctl+          qdtext        = text \\ "\""+          quotedPair    = char '\\' >> anyChar++-- | Get all cookies from the HTTP request. The cookies are ordered per RFC from+-- the most specific to the least specific. Multiple cookies with the same+-- name are allowed to exist.+getCookies :: MonadFail m => C.ByteString -> m [Cookie]+getCookies h = getCookies' h >>=  either (fail. ("Cookie parsing failed!"++)) return++-- | Get the most specific cookie with the given name. Fails if there is no such+-- cookie or if the browser did not escape cookies in a proper fashion.+-- Browser support for escaping cookies properly is very diverse.+getCookie :: MonadFail m => String -> C.ByteString -> m Cookie+getCookie s h = getCookie' s h >>= either (const $ fail ("getCookie: " ++ show s)) return++getCookies' :: Monad m => C.ByteString -> m (Either String [Cookie])+getCookies' header | C.null header = return $ Right []+                   | otherwise     = return $ parseCookies (C.unpack header)++getCookie' :: Monad m => String -> C.ByteString -> m (Either String Cookie)+getCookie' s h = do+    cs <- getCookies' h+    return $ do -- Either+       cooks <- cs+       case filter (\x->(==)  (low s)  (cookieName x) ) cooks of+            [] -> Left "No cookie found"+            f -> return $ head f++low :: String -> String+low = map toLower
+ src/Happstack/Server/Internal/Handler.hs view
@@ -0,0 +1,404 @@+{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables, TupleSections #-}++module Happstack.Server.Internal.Handler+    ( request+    , parseResponse+    , putRequest+    ) where++import qualified Paths_happstack_server as Paths+import qualified Data.Version as DV+import Control.Applicative (pure)+import Control.Concurrent (newMVar, newEmptyMVar, tryTakeMVar)+import Control.Exception.Extensible as E+import Control.Monad+import Data.List(elemIndex)+import Data.Char(toLower)+import Data.Maybe ( fromMaybe, fromJust, isJust, isNothing )+import Data.Time      (UTCTime)+import Prelude hiding (last)+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import           Data.ByteString.Lazy.Internal (ByteString(Chunk, Empty))+import qualified Data.ByteString.Lazy.Char8 as LC+import qualified Data.Map as M+import Data.Int (Int64)+import Happstack.Server.Internal.Cookie+import Happstack.Server.Internal.Clock+import Happstack.Server.Internal.Types+import Happstack.Server.Internal.Multipart+import Happstack.Server.Internal.RFC822Headers+import Happstack.Server.Internal.MessageWrap+import Happstack.Server.SURI(SURI(..),path,query)+import Happstack.Server.SURI.ParseURI+import Happstack.Server.Internal.TimeoutIO (TimeoutIO(..))+import Happstack.Server.Internal.Monads (failResponse)+import qualified Happstack.Server.Internal.TimeoutManager as TM+import Numeric+import System.Directory (removeFile)+import System.IO+import System.IO.Error (isDoesNotExistError)++request :: TimeoutIO -> Maybe (LogAccess UTCTime) -> Host -> (Request -> IO Response) -> IO ()+request timeoutIO mlog host handler =+    rloop timeoutIO mlog host handler =<< toGetContents timeoutIO++required :: String -> Maybe a -> Either String a+required err Nothing  = Left err+required _   (Just a) = Right a++rloop :: TimeoutIO+         -> Maybe (LogAccess UTCTime)+         -> Host+         -> (Request -> IO Response)+         -> L.ByteString+         -> IO ()+rloop timeoutIO mlog host handler inputStr+    | L.null inputStr = return ()+    | otherwise+    = (join $+      do let parseRequest+                 = do+                      (topStr, restStr) <- required "failed to separate request" $ splitAtEmptyLine inputStr+                      (rql, headerStr)  <- required "failed to separate headers/body" $ splitAtCRLF topStr+                      let (m,u,v) = requestLine rql+                      headers' <- case parseHeaders "host" (L.unpack headerStr) of+                        Nothing -> Left "failed to parse host header"+                        Just x -> Right x+                      let headers = mkHeaders headers'+                      let contentLen = fromMaybe 0 $ fmap fst (P.readInt =<< getHeaderUnsafe contentlengthC headers)+                      (body, nextRequest) <- case () of+                          () | contentLen < 0               -> Left "negative content-length"+                             | isJust $ getHeaderBS transferEncodingC headers ->+                                 return $ consumeChunks restStr+                             | otherwise                       -> return (L.splitAt (fromIntegral contentLen) restStr)+                      let cookies = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" headers)), c <- cl ] -- Ugle+                      return (m, u, cookies, v, headers, body, nextRequest)++         case parseRequest of+           Left err -> error $ "failed to parse HTTP request: " ++ err+           Right (m, u, cookies, v, headers, body, nextRequest)+              -> pure $+                  do bodyRef        <- newMVar (Body body)+                     bodyInputRef   <- newEmptyMVar+                     let req = Request (toSecure timeoutIO) m (pathEls (path u)) (path u) (query u)+                                  (queryInput u) bodyInputRef cookies v headers bodyRef host++                     let ioseq act = act >>= \x -> x `seq` return x++                     (res, handlerKilled) <- ((, False) `liftM` ioseq (handler req))+                         `E.catches` [ Handler $ \(e::EscapeHTTP)      -> throwIO e -- need to handle this higher up+                                     , Handler $ \(e::E.SomeException) -> pure (failResponse (show e), fromException e == Just ThreadKilled)+                                     ]++                     case mlog of+                       Nothing -> return ()+                       (Just logger) ->+                           do time <- getApproximateUTCTime+                              let host'        = fst host+                                  user         = "-"+                                  requestLn    = unwords [show $ rqMethod req, rqUri req, show $ rqVersion req]+                                  responseCode = rsCode res+                                  size         = maybe (-1) (readDec' . B.unpack) (getHeader "Content-Length" res) -- -1 indicates unknown size+                                  referer      = B.unpack $ fromMaybe (B.pack "") $ getHeader "Referer" req+                                  userAgent    = B.unpack $ fromMaybe (B.pack "") $ getHeader "User-Agent" req+                              logger host' user time requestLn responseCode size referer userAgent++                     -- withNoPush sock $ putAugmentedResult thandle sock req res+                     putAugmentedResult timeoutIO req res+                     -- clean up tmp files+                     cleanupTempFiles req+                     -- do not continue if handler was killed+                     when (not handlerKilled && continueHTTP req res) $+                         rloop timeoutIO mlog host handler nextRequest) `E.catch` (escapeHttpHandler timeoutIO)++escapeHttpHandler :: TimeoutIO+                  -> EscapeHTTP+                  -> IO ()+escapeHttpHandler tio (EscapeHTTP f) = f tio++-- NOTE: if someone took the inputs and never put them back, then they are responsible for the cleanup+cleanupTempFiles :: Request -> IO ()+cleanupTempFiles req =+    do mInputs <- tryTakeMVar (rqInputsBody req)+       case mInputs of+         Nothing -> return ()+         (Just inputs) -> mapM_ deleteTmpFile inputs+    where+      deleteTmpFile :: (String, Input) -> IO ()+      deleteTmpFile (_, input) =+          case inputValue input of+            (Left fp) -> E.catchJust (guard . isDoesNotExistError) (removeFile fp)  (const $ return ())+            _         -> return ()++-- | Unserializes the bytestring into a response.  If there is an+-- error it will return @Left msg@.+parseResponse :: L.ByteString -> Either String Response+parseResponse inputStr =+    do (topStr,restStr) <- required "failed to separate response" $+                           splitAtEmptyLine inputStr+       (rsl,headerStr) <- required "failed to separate headers/body" $+                          splitAtCRLF topStr+       let (_,code) = responseLine rsl+       headers' <- case parseHeaders "host" (L.unpack headerStr) of+         Nothing -> Left "failed to parse host header"+         Just x -> Right x+       let headers = mkHeaders headers'+       let mbCL = fmap fst (B.readInt =<< getHeader "content-length" headers)+       (body,_) <-+           maybe (if (isNothing $ getHeader "transfer-encoding" headers)+                       then  return (restStr,L.pack "")+                       else  return $ consumeChunks restStr)+                 (\cl->return (L.splitAt (fromIntegral cl) restStr))+                 mbCL+       return $ Response {rsCode=code,rsHeaders=headers,rsBody=body,rsFlags=RsFlags ContentLength,rsValidator=Nothing}++-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html+-- note this does NOT handle extenions+consumeChunks::L.ByteString->(L.ByteString,L.ByteString)+consumeChunks str = let (parts,tr,rest) = consumeChunksImpl str in (L.concat . (++ [tr]) .map snd $ parts,rest)++consumeChunksImpl :: L.ByteString -> ([(Int64, L.ByteString)], L.ByteString, L.ByteString)+consumeChunksImpl str+    | L.null str = ([],L.empty,str)+    | chunkLen == 0 = let (last,rest') = L.splitAt lenLine1 str+                          (tr',rest'') = getTrailer rest'+                      in ([(0,last)],tr',rest'')+    | otherwise = ((chunkLen,part):crest,tr,rest2)+    where+      line1 = head $ lazylines str+      lenLine1 = (L.length line1) + 1 -- endchar+      chunkLen = (fst $ head $ readHex $ L.unpack line1)+      len = chunkLen + lenLine1 + 2+      (part,rest) = L.splitAt len str+      (crest,tr,rest2) = consumeChunksImpl rest+      getTrailer s = L.splitAt index s+          where index | crlfLC `L.isPrefixOf` s = 2+                      | otherwise = let iscrlf = L.zipWith (\a b -> a == '\r' && b == '\n') s . L.tail $ s+                                        Just i = elemIndex True $ zipWith (&&) iscrlf (tail (tail iscrlf))+                                    in fromIntegral $ i+4++crlfLC :: L.ByteString+crlfLC = L.pack "\r\n"++-- Properly lazy version of 'lines' for lazy bytestrings+lazylines           :: L.ByteString -> [L.ByteString]+lazylines s+    | L.null s  = []+    | otherwise =+        let (l,s') = L.break ((==) '\n') s+        in l : if L.null s' then []+                            else lazylines (L.tail s')++requestLine :: L.ByteString -> (Method, SURI, HttpVersion)+requestLine l = case P.words ((P.concat . L.toChunks) l) of+                  [rq,uri,ver] -> (method rq, SURI $ parseURIRef uri, version ver)+                  [rq,uri] -> (method rq, SURI $ parseURIRef uri,HttpVersion 0 9)+                  x -> error $ "requestLine cannot handle input:  " ++ (show x)++responseLine :: L.ByteString -> (B.ByteString, Int)+responseLine l = case B.words ((B.concat . L.toChunks) l) of+                   (v:c:_) -> version v `seq` (v,fst (fromJust (B.readInt c)))+                   x -> error $ "responseLine cannot handle input: " ++ (show x)+++method :: B.ByteString -> Method+method r = fj $ lookup r mtable+    where fj (Just x) = x+          fj Nothing  = EXTENSION r+          mtable = [ (P.pack "GET",     GET)+                   , (P.pack "HEAD",    HEAD)+                   , (P.pack "POST",    POST)+                   , (P.pack "PUT",     PUT)+                   , (P.pack "DELETE",  DELETE)+                   , (P.pack "TRACE",   TRACE)+                   , (P.pack "OPTIONS", OPTIONS)+                   , (P.pack "CONNECT", CONNECT)+                   , (P.pack "PATCH",   PATCH)+                   ]++-- Result side++staticHeaders :: Headers+staticHeaders =+    foldr (uncurry setHeaderBS) (mkHeaders [])+    [ (serverC, happstackC) ]++-- FIXME: we should not be controlling the response headers in mysterious ways in this low level code+-- headers should be set by application code and the core http engine should be very lean.+putAugmentedResult :: TimeoutIO -> Request -> Response -> IO ()+putAugmentedResult timeoutIO req res = do+    case res of+        -- standard bytestring response+        Response {} -> do+            let isChunked = rsfLength (rsFlags res) == TransferEncodingChunked && isHTTP1_1 req+            sendTop (if isChunked then Nothing else (Just (fromIntegral (L.length (rsBody res))))) isChunked+            when (rqMethod req /= HEAD)+                     (let body = if isChunked+                                 then chunk (rsBody res)+                                 else rsBody res+                      in toPutLazy timeoutIO body)+        -- zero-copy sendfile response+        -- the handle *should* be closed by the garbage collector++        SendFile {} -> do+            let infp = sfFilePath res+                off = sfOffset res+                count = sfCount res+            sendTop (Just count) False+            TM.tickle (toHandle timeoutIO)+            toSendFile timeoutIO infp off count++    where ph (HeaderPair k vs) = map (\v -> P.concat [k, fsepC, v, crlfC]) vs+          sendTop cl isChunked = do+              allHeaders <- augmentHeaders req res cl isChunked+              toPut timeoutIO $ B.concat $ concat+                 [ (pversion $ rqVersion req)          -- Print HTTP version+                 , [responseMessage $ rsCode res]      -- Print responseCode+                 , concatMap ph (M.elems allHeaders)   -- Print all headers+                 , [crlfC]+                 ]+              TM.tickle (toHandle timeoutIO)+          chunk :: L.ByteString -> L.ByteString+          chunk Empty        = LC.pack "0\r\n\r\n"+          chunk (Chunk c cs) = Chunk (B.pack $ showHex (B.length c) "\r\n") (Chunk c (Chunk (B.pack "\r\n") (chunk cs)))++augmentHeaders :: Request -> Response -> Maybe Integer -> Bool -> IO Headers+augmentHeaders req res mcl isChunked = do+    -- TODO: Hoist static headers to the toplevel.+    raw <- getApproximateTime+    let stdHeaders = staticHeaders `M.union`+          M.fromList ( [ (dateCLower,       HeaderPair dateC [raw])+                       , (connectionCLower, HeaderPair connectionC [if continueHTTP req res then keepAliveC else closeC])+                       ] ++ case rsfLength (rsFlags res) of+                              NoContentLength -> []+                              ContentLength | not (hasHeader "Content-Length" res) ->+                                                case mcl of+                                                  (Just cl) -> [(contentlengthC, HeaderPair contentLengthC [P.pack (show cl)])]+                                                  _ -> []+                                            | otherwise -> []+                              TransferEncodingChunked+                                  -- we check 'chunked' because we might not use this mode if the client is http 1.0+                                  | isChunked -> [(transferEncodingC, HeaderPair transferEncodingC [chunkedC])]+                                  | otherwise -> []++                     )+    return (rsHeaders res `M.union` stdHeaders) -- 'union' prefers 'headers res' when duplicate keys are encountered.++-- | Serializes the request to the given handle+putRequest :: Handle -> Request -> IO ()+putRequest h rq = do+    let put = B.hPut h+        ph (HeaderPair k vs) = map (\v -> B.concat [k, fsepC, v, crlfC]) vs+        sp = [B.pack " "]+    mapM_ put $ concat+      [[B.pack $ show $ rqMethod rq],sp+      ,[B.pack $ rqURL rq],sp+      ,(pversion $ rqVersion rq), [crlfC]+      ,concatMap ph (M.elems $ rqHeaders rq)+      ,[crlfC]+      ]+    mBody <- takeRequestBody rq -- tryTakeMVar (rqBody rq)+    L.hPut h (maybe L.empty unBody mBody) -- FIXME: should this actually be an error if the body is null?+    hFlush h++-- HttpVersion++pversion :: HttpVersion -> [B.ByteString]+pversion (HttpVersion 1 1) = [http11]+pversion (HttpVersion 1 0) = [http10]+pversion (HttpVersion x y) = [P.pack "HTTP/", P.pack (show x), P.pack ".", P.pack (show y)]++version :: B.ByteString -> HttpVersion+version x | x == http09 = HttpVersion 0 9+          | x == http10 = HttpVersion 1 0+          | x == http11 = HttpVersion 1 1+          | otherwise   = error "Invalid HTTP version"++http09 :: B.ByteString+http09 = P.pack "HTTP/0.9"+http10 :: B.ByteString+http10 = P.pack "HTTP/1.0"+http11 :: B.ByteString+http11 = P.pack "HTTP/1.1"++-- * ByteString Constants++connectionC :: B.ByteString+connectionC      = P.pack "Connection"+connectionCLower :: B.ByteString+connectionCLower = P.map toLower connectionC+closeC :: B.ByteString+closeC           = P.pack "close"+keepAliveC :: B.ByteString+keepAliveC       = P.pack "Keep-Alive"+crlfC :: B.ByteString+crlfC            = P.pack "\r\n"+fsepC :: B.ByteString+fsepC            = P.pack ": "+-- contentTypeC :: B.ByteString+-- contentTypeC     = P.pack "Content-Type"+contentLengthC :: B.ByteString+contentLengthC   = P.pack "Content-Length"+contentlengthC :: B.ByteString+contentlengthC   = P.pack "content-length"+dateC :: B.ByteString+dateC            = P.pack "Date"+dateCLower :: B.ByteString+dateCLower       = P.map toLower dateC+serverC :: B.ByteString+serverC          = P.pack "Server"+happstackC :: B.ByteString+happstackC           = P.pack $ "Happstack/" ++ DV.showVersion Paths.version+-- textHtmlC :: B.ByteString+-- textHtmlC        = P.pack "text/html; charset=utf-8"+transferEncodingC :: B.ByteString+transferEncodingC = P.pack "Transfer-Encoding"+chunkedC :: B.ByteString+chunkedC = P.pack "chunked"++-- Response code names++responseMessage :: (Num t, Show t, Eq t) => t -> B.ByteString+responseMessage 100 = P.pack " 100 Continue\r\n"+responseMessage 101 = P.pack " 101 Switching Protocols\r\n"+responseMessage 200 = P.pack " 200 OK\r\n"+responseMessage 201 = P.pack " 201 Created\r\n"+responseMessage 202 = P.pack " 202 Accepted\r\n"+responseMessage 203 = P.pack " 203 Non-Authoritative Information\r\n"+responseMessage 204 = P.pack " 204 No Content\r\n"+responseMessage 205 = P.pack " 205 Reset Content\r\n"+responseMessage 206 = P.pack " 206 Partial Content\r\n"+responseMessage 300 = P.pack " 300 Multiple Choices\r\n"+responseMessage 301 = P.pack " 301 Moved Permanently\r\n"+responseMessage 302 = P.pack " 302 Found\r\n"+responseMessage 303 = P.pack " 303 See Other\r\n"+responseMessage 304 = P.pack " 304 Not Modified\r\n"+responseMessage 305 = P.pack " 305 Use Proxy\r\n"+responseMessage 307 = P.pack " 307 Temporary Redirect\r\n"+responseMessage 400 = P.pack " 400 Bad Request\r\n"+responseMessage 401 = P.pack " 401 Unauthorized\r\n"+responseMessage 402 = P.pack " 402 Payment Required\r\n"+responseMessage 403 = P.pack " 403 Forbidden\r\n"+responseMessage 404 = P.pack " 404 Not Found\r\n"+responseMessage 405 = P.pack " 405 Method Not Allowed\r\n"+responseMessage 406 = P.pack " 406 Not Acceptable\r\n"+responseMessage 407 = P.pack " 407 Proxy Authentication Required\r\n"+responseMessage 408 = P.pack " 408 Request Time-out\r\n"+responseMessage 409 = P.pack " 409 Conflict\r\n"+responseMessage 410 = P.pack " 410 Gone\r\n"+responseMessage 411 = P.pack " 411 Length Required\r\n"+responseMessage 412 = P.pack " 412 Precondition Failed\r\n"+responseMessage 413 = P.pack " 413 Request Entity Too Large\r\n"+responseMessage 414 = P.pack " 414 Request-URI Too Large\r\n"+responseMessage 415 = P.pack " 415 Unsupported Media Type\r\n"+responseMessage 416 = P.pack " 416 Requested range not satisfiable\r\n"+responseMessage 417 = P.pack " 417 Expectation Failed\r\n"+responseMessage 500 = P.pack " 500 Internal Server Error\r\n"+responseMessage 501 = P.pack " 501 Not Implemented\r\n"+responseMessage 502 = P.pack " 502 Bad Gateway\r\n"+responseMessage 503 = P.pack " 503 Service Unavailable\r\n"+responseMessage 504 = P.pack " 504 Gateway Time-out\r\n"+responseMessage 505 = P.pack " 505 HTTP Version not supported\r\n"+responseMessage x   = P.pack (" " ++ show x ++ " \r\n")
+ src/Happstack/Server/Internal/LazyLiner.hs view
@@ -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
+ src/Happstack/Server/Internal/Listen.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}+module Happstack.Server.Internal.Listen(listen, listen',listenOn,listenOnIPv4) where++import Data.Maybe                               (isNothing)+import Happstack.Server.Internal.Types          (Conf(..), Request, Response)+import Happstack.Server.Internal.Handler        (request)+import Happstack.Server.Internal.Socket         (acceptLite)+import Happstack.Server.Internal.TimeoutManager (cancel, initialize, register, forceTimeoutAll)+import Happstack.Server.Internal.TimeoutSocket  as TS+import qualified Control.Concurrent.Thread.Group as TG+import Control.Exception.Extensible             as E+import Control.Concurrent                       (forkIO, killThread, myThreadId)+import Control.Monad+import qualified Data.Maybe as Maybe+import qualified Network.Socket                 as Socket+import System.IO.Error                          (isFullError)+import Foreign.C (CInt)+{-+#ifndef mingw32_HOST_OS+-}+import System.Posix.Signals+{-+#endif+-}+import System.Log.Logger (Priority(..), logM)+log':: Priority -> String -> IO ()+log' = logM "Happstack.Server.HTTP.Listen"++-- Meant to be TCP in practise.+-- See https://www.gnu.org/software/libc/manual/html_node/Creating-a-Socket.html+-- which says "zero is usually right".  It could theoretically be SCTP, but it+-- would be a bizarre system that defaults to SCTP over TCP.+proto :: CInt+proto = Socket.defaultProtocol++{-+   Network.listenOn binds randomly to IPv4 or IPv6 or both,+   depending on system and local settings.+   Lets make it use IPv4 only for now.+-}++listenOn :: Int -> IO Socket.Socket+listenOn portm = do+    E.bracketOnError+        (Socket.socket Socket.AF_INET Socket.Stream proto)+        (Socket.close)+        (\sock -> do+            Socket.setSocketOption sock Socket.ReuseAddr 1+            Socket.bind sock (Socket.SockAddrInet (fromIntegral portm) iNADDR_ANY)+            Socket.listen sock (max 1024 Socket.maxListenQueue)+            return sock+        )++listenOnIPv4 :: String  -- ^ IP address to listen on (must be an IP address not a host name)+             -> Int     -- ^ port number to listen on+             -> IO Socket.Socket+listenOnIPv4 ip portm = do+    hostAddr <- inet_addr ip+    E.bracketOnError+        (Socket.socket Socket.AF_INET Socket.Stream proto)+        (Socket.close)+        (\sock -> do+            Socket.setSocketOption sock Socket.ReuseAddr 1+            Socket.bind sock (Socket.SockAddrInet (fromIntegral portm) hostAddr)+            Socket.listen sock (max 1024 Socket.maxListenQueue)+            return sock+        )++inet_addr :: String -> IO Socket.HostAddress+inet_addr ip = do+  addrInfos <- Socket.getAddrInfo (Just Socket.defaultHints) (Just ip) Nothing+  let getHostAddress addrInfo = case Socket.addrAddress addrInfo of+        Socket.SockAddrInet _ hostAddress -> Just hostAddress+        _ -> Nothing+  maybe (fail "inet_addr: no HostAddress") pure+    . Maybe.listToMaybe+    $ Maybe.mapMaybe getHostAddress addrInfos++iNADDR_ANY :: Socket.HostAddress+iNADDR_ANY = 0++-- | Bind and listen port+listen :: Conf -> (Request -> IO Response) -> IO ()+listen conf hand = do+    let port' = port conf+    lsocket <- listenOn port'+    Socket.setSocketOption lsocket Socket.KeepAlive 1+    listen' lsocket conf hand++-- | Use a previously bind port and listen+listen' :: Socket.Socket -> Conf -> (Request -> IO Response) -> IO ()+listen' s conf hand = do+{-+#ifndef mingw32_HOST_OS+-}+  void $ installHandler openEndedPipe Ignore Nothing+{-+#endif+-}+  let port' = port conf+      fork = case threadGroup conf of+               Nothing -> forkIO+               Just tg -> \m -> fst `liftM` TG.forkIO tg m+  tm <- initialize ((timeout conf) * (10^(6 :: Int)))+  -- http:// loop+  log' NOTICE ("Listening for http:// on port " ++ show port')+  let eh (x::SomeException) = when ((fromException x) /= Just ThreadKilled) $ log' ERROR ("HTTP request failed with: " ++ show x)+      work (sock, hn, p) =+          do tid <- myThreadId+             thandle <- register tm (killThread tid)+             let timeoutIO = TS.timeoutSocketIO thandle sock+             request timeoutIO (logAccess conf) (hn,fromIntegral p) hand `E.catch` eh+             -- remove thread from timeout table+             cancel thandle+             Socket.close sock+      loop = forever $ do w <- acceptLite s+                          fork $ work w+      pe e = log' ERROR ("ERROR in http accept thread: " ++ show e)+      infi :: IO ()+      infi = loop `catchSome` pe >> infi++  infi `finally` (Socket.close s >> when (isNothing $ threadGroup conf) (forceTimeoutAll tm))++{--+#ifndef mingw32_HOST_OS+-}+  void $ installHandler openEndedPipe Ignore Nothing+{-+#endif+-}+  where  -- why are these handlers needed?++    catchSome op h = op `E.catches` [+            Handler $ \(e :: ArithException) -> h (toException e),+            Handler $ \(e :: ArrayException) -> h (toException e),+            Handler $ \(e :: IOException)    ->+                if isFullError e+                   then return () -- h (toException e) -- we could log the exception, but there could be thousands of them+                   else throw e+          ]
+ src/Happstack/Server/Internal/LogFormat.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE CPP #-}+module Happstack.Server.Internal.LogFormat+  ( formatTimeCombined+  , formatRequestCombined+  ) where++import Data.Time.Format (FormatTime(..), formatTime, defaultTimeLocale)++-- | Format the time as describe in the Apache combined log format.+--   http://httpd.apache.org/docs/2.2/logs.html#combined+--+-- The format is:+--   [day/month/year:hour:minute:second zone]+--    day = 2*digit+--    month = 3*letter+--    year = 4*digit+--    hour = 2*digit+--    minute = 2*digit+--    second = 2*digit+--    zone = (`+' | `-') 4*digit+formatTimeCombined :: FormatTime t => t -> String+formatTimeCombined = formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z"++-- | Format the request as describe in the Apache combined log format.+--   http://httpd.apache.org/docs/2.2/logs.html#combined+--+-- The format is: "%h - %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-agent}i\""+-- %h:            This is the IP address of the client (remote host) which made the request to the server.+-- %u:            This is the userid of the person requesting the document as determined by HTTP authentication.+-- %t:            The time that the request was received.+-- %r:            The request line from the client is given in double quotes.+-- %>s:           This is the status code that the server sends back to the client.+-- %b:            The last part indicates the size of the object returned to the client, not including the response headers.+-- %{Referer}:    The "Referer" (sic) HTTP request header.+-- %{User-agent}: The User-Agent HTTP request header.+formatRequestCombined :: FormatTime t =>+  String+  -> String+  -> t+  -> String+  -> Int+  -> Integer+  -> String+  -> String+  -> String+formatRequestCombined host user time requestLine responseCode size referer userAgent =+  unwords+    [ host+    , user+    , "[" ++ formattedTime ++ "]"+    , show requestLine+    , show responseCode+    , show size+    , show referer+    , show userAgent+    ]+  where formattedTime = formatTimeCombined time
+ src/Happstack/Server/Internal/LowLevel.hs view
@@ -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.
+ src/Happstack/Server/Internal/MessageWrap.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE FlexibleInstances #-}++module Happstack.Server.Internal.MessageWrap (+        module Happstack.Server.Internal.MessageWrap+        ,defaultInputIter+   ) where++import Control.Concurrent.MVar (tryTakeMVar, tryPutMVar, putMVar)+import Control.Monad.Trans (MonadIO(liftIO))+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.UTF8  as U (toString)+import Data.Int (Int64)+import Happstack.Server.Internal.Types as H+import Happstack.Server.Internal.Multipart+import Happstack.Server.Internal.RFC822Headers (parseContentType)+import Happstack.Server.SURI as SURI++queryInput :: SURI -> [(String, Input)]+queryInput uri = formDecode (case SURI.query uri of+                               '?':r -> r+                               xs    -> xs)++-- | see 'defaultBodyPolicy'+data BodyPolicy+    = BodyPolicy { inputWorker :: Int64 -> Int64 -> Int64 -> InputWorker+                 , maxDisk     :: Int64 -- ^ maximum bytes for files uploaded in this 'Request'+                 , maxRAM      :: Int64 -- ^ maximum bytes for all non-file values in the 'Request' body+                 , maxHeader   :: Int64 -- ^ maximum bytes of overhead for headers in @multipart/form-data@+                 }++-- | create a 'BodyPolicy' for use with decodeBody+defaultBodyPolicy :: FilePath -- ^ temporary directory for file uploads+                  -> Int64 -- ^ maximum bytes for files uploaded in this 'Request'+                  -> Int64 -- ^ maximum bytes for all non-file values in the 'Request' body+                  -> Int64 -- ^ maximum bytes of overhead for headers in @multipart/form-data@+                  -> BodyPolicy+defaultBodyPolicy tmpDir md mr mh =+    BodyPolicy { inputWorker = defaultInputIter defaultFileSaver tmpDir 0 0 0+               , maxDisk   = md+               , maxRAM    = mr+               , maxHeader = mh+               }++bodyInput :: (MonadIO m) => BodyPolicy -> Request -> m ([(String, Input)], Maybe String)+bodyInput _ req | (not (canHaveBody (rqMethod req))) || (not (isDecodable ctype)) =+    do _ <- liftIO $ tryPutMVar (rqInputsBody req) []+       return ([], Nothing)+    where+      ctype :: Maybe ContentType+      ctype = parseContentType . P.unpack =<< getHeader "content-type" req+      isDecodable :: Maybe ContentType -> Bool+      isDecodable Nothing                                                      = True -- assume it is application/x-www-form-urlencoded+      isDecodable (Just (ContentType "application" "x-www-form-urlencoded" _)) = True+      isDecodable (Just (ContentType "multipart" "form-data" _ps))             = True+      isDecodable (Just _)                                                     = False++bodyInput bodyPolicy req =+  liftIO $+    do let ctype = parseContentType . P.unpack =<< getHeader "content-type" req+       mbi <- tryTakeMVar (rqInputsBody req)+       case mbi of+         (Just bi) ->+             do putMVar (rqInputsBody req) bi+                return (bi, Nothing)+         Nothing ->+             do rqbody <- takeRequestBody req+                case rqbody of+                  Nothing          -> return ([], Just $ "bodyInput: Request body was already consumed.")+                  (Just (Body bs)) ->+                      do r@(inputs, _err) <- decodeBody bodyPolicy ctype bs+                         putMVar (rqInputsBody req) inputs+                         return r++-- | Decodes application\/x-www-form-urlencoded inputs.+-- TODO: should any of the [] be error conditions?+formDecode :: String -> [(String, Input)]+formDecode [] = []+formDecode qString =+    if null pairString then rest else+           (SURI.unEscapeQS name,simpleInput $ SURI.unEscapeQS val):rest+    where (pairString,qString')= split (=='&') qString+          (name,val)=split (=='=') pairString+          rest=if null qString' then [] else formDecode qString'++-- | Decodes application\/x-www-form-urlencoded inputs.+-- TODO: should any of the [] be error conditions?+formDecodeBS :: L.ByteString -> [(String, Input)]+formDecodeBS qString | L.null qString = []+formDecodeBS qString =+    if L.null pairString+       then rest            -- skip in case of consecutive ampersands "...&&..."+       else (SURI.unEscapeQS (L.unpack name), simpleInput $ SURI.unEscapeQS (L.unpack $ L.drop 1 val)) : rest+    where (pairString,qString') = L.break (== '&') qString+          (name,val) = L.break (== '=') pairString+          rest = formDecodeBS (L.drop 1 qString')++-- FIXME: is usend L.unpack really the right thing to do+decodeBody :: BodyPolicy+           -> Maybe ContentType+           -> L.ByteString+           -> IO ([(String,Input)], Maybe String)+decodeBody bp ctype inp+    = case ctype of+        Just (ContentType "application" "x-www-form-urlencoded" _) ->+            return decodedUrlEncodedForm+        Just (ContentType "multipart" "form-data" ps) ->+            multipartDecode ((inputWorker bp) (maxDisk bp) (maxRAM bp) (maxHeader bp)) ps inp+        Just ct ->+            return ([], Just $ "decodeBody: unsupported content-type: " ++ show ct) -- unknown content-type, the user will have to+                     -- deal with it by looking at the raw content+        -- No content-type given, assume x-www-form-urlencoded+        Nothing -> return decodedUrlEncodedForm+  where+     (upToMaxRAM,overMaxRAM) = L.splitAt (maxRAM bp) inp+     decodedUrlEncodedForm = (formDecodeBS upToMaxRAM,+                              if L.null overMaxRAM+                              then Nothing+                              else Just ("x-www-form-urlencoded content longer than BodyPolicy.maxRAM=" ++ show (maxRAM bp) ++ " bytes"))++-- | Decodes multipart\/form-data input.+multipartDecode :: InputWorker+                -> [(String,String)] -- ^ Content-type parameters+                -> L.ByteString      -- ^ Request body+                -> IO ([(String,Input)], Maybe String) -- ^ Input variables and values.+multipartDecode worker ps inp =+    case lookup "boundary" ps of+         Just b  -> multipartBody worker (L.pack b) inp+         Nothing -> return ([], Just $ "boundary not found in parameters: " ++ show ps)++-- | Get the path components from a String.+pathEls :: String -> [String]+pathEls = (drop 1) . map (U.toString . P.pack . SURI.unEscape) . splitList '/'++-- | Repeadly splits a list by the provided separator and collects the results+splitList :: Eq a => a -> [a] -> [[a]]+splitList _   [] = []+splitList sep list = h:splitList sep t+        where (h,t)=split (==sep) list++-- | Repeatedly splits a list and collects the results+splitListBy :: (a -> Bool) -> [a] -> [[a]]+splitListBy _ [] = []+splitListBy f list = h:splitListBy f t+        where (h,t)=split f list++-- | Split is like break, but the matching element is dropped.+split :: (a -> Bool) -> [a] -> ([a], [a])+split f s = (left,right)+        where+        (left,right')=break f s+        right = if null right' then [] else tail right'+
+ src/Happstack/Server/Internal/Monads.hs view
@@ -0,0 +1,800 @@+{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeFamilies, UndecidableInstances  #-}+{-| This module defines the Monad stack used by Happstack. You mostly don't want to be looking in here. Look in "Happstack.Server.Monads" instead.+-}+module Happstack.Server.Internal.Monads where++import Control.Applicative                       (Applicative, pure, (<*>), Alternative(empty,(<|>)))++import Control.Concurrent                        (newMVar)+import Control.Exception                         (throwIO)++import Control.Monad                             ( MonadPlus(mzero, mplus), ap, liftM, msum+                                                 )+import Control.Monad.Base                        ( MonadBase, liftBase )+import Control.Monad.Catch                       ( MonadCatch(..), MonadThrow(..) )+#if !MIN_VERSION_transformers(0,6,0)+import Control.Monad.Trans.Error                 ( ErrorT, Error, mapErrorT )+#endif+import Control.Monad.Except                      ( MonadError, throwError+                                                 , catchError+                                                 )+#if MIN_VERSION_base(4,9,0)+import Control.Monad.Fail                        (MonadFail)+import qualified Control.Monad.Fail              as Fail+#endif+import Control.Monad.Reader                      ( ReaderT(ReaderT), runReaderT+                                                 , MonadReader, ask, local, mapReaderT+                                                 )+import qualified Control.Monad.RWS.Lazy as Lazy       ( RWST, mapRWST )+import qualified Control.Monad.RWS.Strict as Strict   ( RWST, mapRWST )++import Control.Monad.Trans.Except                ( ExceptT(ExceptT), mapExceptT, runExceptT )+import Control.Monad.State.Class                      ( MonadState, get, put )+import qualified Control.Monad.State.Lazy as Lazy     ( StateT, mapStateT )+import qualified Control.Monad.State.Strict as Strict ( StateT, mapStateT )+import Control.Monad.Trans                       ( MonadTrans, lift+                                                 , MonadIO, liftIO+                                                 )+import Control.Monad.Trans.Control               ( MonadTransControl(..)+                                                 , MonadBaseControl(..)+                                                 , ComposeSt, defaultLiftBaseWith, defaultRestoreM+                                                 )+import Control.Monad.Writer.Class                ( MonadWriter, tell, pass, listens )+import qualified Control.Monad.Writer.Lazy as Lazy     ( WriterT(WriterT), runWriterT, mapWriterT )+import qualified Control.Monad.Writer.Strict as Strict ( WriterT, mapWriterT )+import qualified Control.Monad.Writer.Class as Writer  ( listen )++import Control.Monad.Trans.Maybe                 (MaybeT(MaybeT), runMaybeT)+import qualified Data.ByteString.Char8           as P+import qualified Data.ByteString.Lazy.UTF8       as LU (fromString)+import Data.Char                                 (ord)+import Data.List                                 (inits, isPrefixOf, stripPrefix, tails)+import Data.Maybe                                (fromMaybe)+import Data.Monoid                               (Monoid(mempty, mappend), Dual(..), Endo(..))+import qualified Data.Semigroup                  as SG+import qualified Paths_happstack_server          as Cabal+import qualified Data.Version                    as DV+import Debug.Trace                               (trace)++import Happstack.Server.Internal.Cookie          (Cookie)+import Happstack.Server.Internal.RFC822Headers   (parseContentType)+import Happstack.Server.Internal.Types           (EscapeHTTP(..), canHaveBody)+import Happstack.Server.Internal.TimeoutIO       (TimeoutIO)+import Happstack.Server.Types+import Prelude                                   (Bool(..), Either(..), Eq(..), Functor(..), IO, Monad(..), Char, Maybe(..), String, Show(..), ($), (.), (>), (++), (&&), (||), (=<<), const, concatMap, flip, id, otherwise, zip)++-- | An alias for 'WebT' when using 'IO'.+type Web a = WebT IO a++-- | An alias for @'ServerPartT' 'IO'@+type ServerPart a = ServerPartT IO a++--------------------------------------+-- HERE BEGINS ServerPartT definitions++-- | 'ServerPartT' is a rich, featureful monad for web development.+--+-- see also: 'simpleHTTP', 'ServerMonad', 'FilterMonad', 'WebMonad', and 'HasRqData'+newtype ServerPartT m a = ServerPartT { unServerPartT :: ReaderT Request (WebT m) a }+#if MIN_VERSION_base(4,9,0)+    deriving (Monad, MonadFail, MonadPlus, Functor)+#else+    deriving (Monad, MonadPlus, Functor)+#endif++instance MonadCatch m => MonadCatch (ServerPartT m) where+    catch action handle = ServerPartT $ catch (unServerPartT action) (unServerPartT . handle)++instance MonadThrow m => MonadThrow (ServerPartT m) where+    throwM = ServerPartT . throwM++instance MonadBase b m => MonadBase b (ServerPartT m) where+    liftBase = lift . liftBase++instance (MonadIO m) => MonadIO (ServerPartT m) where+    liftIO = ServerPartT . liftIO+    {-# INLINE liftIO #-}++instance MonadTransControl ServerPartT where+    type StT ServerPartT a = StT WebT (StT (ReaderT Request) a)+    liftWith f = ServerPartT $ liftWith $ \runReader ->+                                 liftWith $ \runWeb ->+                                   f $ runWeb . runReader . unServerPartT+    restoreT = ServerPartT . restoreT . restoreT++instance MonadBaseControl b m => MonadBaseControl b (ServerPartT m) where+    type StM (ServerPartT m) a = ComposeSt ServerPartT m a+    liftBaseWith = defaultLiftBaseWith+    restoreM     = defaultRestoreM++-- | Particularly useful when combined with 'runWebT' to produce+-- a @m ('Maybe' 'Response')@ from a 'Request'.+runServerPartT :: ServerPartT m a -> Request -> WebT m a+runServerPartT = runReaderT . unServerPartT++-- | function for lifting WebT to ServerPartT+--+-- NOTE: This is mostly for internal use. If you want to access the+-- 'Request' in user-code see 'askRq' from 'ServerMonad'.+--+-- > do request <- askRq+-- >    ...+withRequest :: (Request -> WebT m a) -> ServerPartT m a+withRequest = ServerPartT . ReaderT++-- | A constructor for a 'ServerPartT' when you don't care about the request.+--+-- NOTE: This is mostly for internal use. If you think you need to use+-- it in your own code, you might consider asking on the mailing list+-- or IRC to find out if there is an alternative solution.+anyRequest :: Monad m => WebT m a -> ServerPartT m a+anyRequest x = withRequest $ \_ -> x++-- | Apply a function to transform the inner monad of+-- @'ServerPartT' m@.+--+-- Often used when transforming a monad with 'ServerPartT', since+-- 'simpleHTTP' requires a @'ServerPartT' 'IO' a@.  Refer to 'UnWebT'+-- for an explanation of the structure of the monad.+--+-- Here is an example.  Suppose you want to embed an 'ErrorT' into your+-- 'ServerPartT' to enable 'throwError' and 'catchError' in your 'Monad'.+--+-- > type MyServerPartT e m a = ServerPartT (ErrorT e m) a+--+-- Now suppose you want to pass @MyServerPartT@ into a function that+-- demands a @'ServerPartT' 'IO' a@ (e.g. 'simpleHTTP').  You can+-- provide the function:+--+-- >   unpackErrorT :: (Monad m, Show e) => UnWebT (ErrorT e m) a -> UnWebT m a+-- >   unpackErrorT et = do+-- >      eitherV <- runErrorT et+-- >      return $ case eitherV of+-- >          Left err -> Just (Left $ toResponse $+-- >                                   "Catastrophic failure " ++ show err+-- >                           , filterFun $ \r -> r{rsCode = 500})+-- >          Right x -> x+--+-- With @unpackErrorT@ you can now call 'simpleHTTP'. Just wrap your+-- 'ServerPartT' list.+--+-- >  simpleHTTP nullConf $ mapServerPartT unpackErrorT (myPart `catchError` myHandler)+--+-- Or alternatively:+--+-- >  simpleHTTP' unpackErrorT nullConf (myPart `catchError` myHandler)+--+-- Also see 'Happstack.Server.Error.spUnwrapErrorT' for a more sophisticated version of this+-- function.+--+mapServerPartT :: (     UnWebT m a ->      UnWebT n b)+               -> (ServerPartT m a -> ServerPartT n b)+mapServerPartT f ma = withRequest $ \rq -> mapWebT f (runServerPartT ma rq)++-- | A variant of 'mapServerPartT' where the first argument also takes+-- a 'Request'.  Useful if you want to 'runServerPartT' on a different+-- 'ServerPartT' inside your monad (see 'spUnwrapErrorT').+mapServerPartT' :: (Request -> UnWebT m a ->      UnWebT n b)+                -> (      ServerPartT m a -> ServerPartT n b)+mapServerPartT' f ma = withRequest $ \rq -> mapWebT (f rq) (runServerPartT ma rq)++instance MonadTrans (ServerPartT) where+    lift m = withRequest (\_ -> lift m)++instance (Monad m, MonadPlus m) => SG.Semigroup (ServerPartT m a) where+    (<>) = mplus++instance (Monad m, MonadPlus m) => Monoid (ServerPartT m a) where+    mempty  = mzero+    mappend = (SG.<>)++instance (Monad m, Functor m) => Applicative (ServerPartT m) where+    pure = return+    (<*>) = ap++instance (Functor m, MonadPlus m) => Alternative (ServerPartT m) where+    empty = mzero+    (<|>) = mplus++instance (Monad m, MonadWriter w m) => MonadWriter w (ServerPartT m) where+    tell = lift . tell+    listen m = withRequest $ \rq ->  Writer.listen (runServerPartT m rq) >>= return+    pass m = withRequest $ \rq -> pass (runServerPartT m rq) >>= return++instance (Monad m, MonadError e m) => MonadError e (ServerPartT m) where+    throwError e = lift $ throwError e+    catchError action handler = withRequest $ \rq -> (runServerPartT action rq) `catchError` ((flip runServerPartT $ rq) . handler)++instance (Monad m, MonadReader r m) => MonadReader r (ServerPartT m) where+    ask = lift ask+    local fn m = withRequest $ \rq-> local fn (runServerPartT m rq)++instance (Monad m, MonadState s m) => MonadState s (ServerPartT m) where+    get = lift get+    put = lift . put++instance Monad m => FilterMonad Response (ServerPartT m) where+    setFilter = anyRequest . setFilter+    composeFilter = anyRequest . composeFilter+    getFilter m = withRequest $ \rq -> getFilter (runServerPartT m rq)++instance Monad m => WebMonad Response (ServerPartT m) where+    finishWith r = anyRequest $ finishWith r++-- | The 'ServerMonad' class provides methods for reading or locally+-- modifying the 'Request'. It is essentially a specialized version of+-- the 'MonadReader' class. Providing the unique names, 'askRq' and+-- 'localRq' makes it easier to use 'ServerPartT' and 'ReaderT'+-- together.+class Monad m => ServerMonad m where+    askRq   :: m Request+    localRq :: (Request -> Request) -> m a -> m a++instance (Monad m) => ServerMonad (ServerPartT m) where+    askRq = ServerPartT $ ask+    localRq f m = ServerPartT $ local f (unServerPartT m)++-- | Implementation of 'askRqEnv' for arbitrary 'ServerMonad'.+smAskRqEnv :: (ServerMonad m, MonadIO m) => m ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)])+smAskRqEnv = do+    rq  <- askRq+    mbi <- liftIO $ if (canHaveBody (rqMethod rq)) && (isDecodable (ctype rq))+      then readInputsBody rq+      else return (Just [])+    return (rqInputsQuery rq, mbi, rqCookies rq)+    where+        ctype :: Request -> Maybe ContentType+        ctype req = parseContentType . P.unpack =<< getHeader "content-type" req++        isDecodable :: Maybe ContentType -> Bool+        isDecodable Nothing                                                      = True -- assume it is application/x-www-form-urlencoded+        isDecodable (Just (ContentType "application" "x-www-form-urlencoded" _)) = True+        isDecodable (Just (ContentType "multipart" "form-data" _ps))             = True+        isDecodable (Just _)                                                     = False++-- | Implementation of 'localRqEnv' for arbitrary 'ServerMonad'.+smLocalRqEnv :: (ServerMonad m, MonadIO m) => (([(String, Input)], Maybe [(String, Input)], [(String, Cookie)]) -> ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)])) -> m b -> m b+smLocalRqEnv f m = do+    rq <- askRq+    b  <- liftIO $ readInputsBody rq+    let (q', b', c') = f (rqInputsQuery rq, b, rqCookies rq)+    bv <- liftIO $ newMVar (fromMaybe [] b')+    let rq' = rq { rqInputsQuery = q'+                 , rqInputsBody = bv+                 , rqCookies = c'+                 }+    localRq (const rq') m++-------------------------------+-- HERE BEGINS WebT definitions++-- | A monoid operation container.  If @a@ is a monoid, then+-- 'SetAppend' is a monoid with the following behaviors:+--+-- >  Set    x `mappend` Append y = Set    (x `mappend` y)+-- >  Append x `mappend` Append y = Append (x `mappend` y)+-- >  _        `mappend` Set y    = Set y+--+-- A simple way of summarizing this is, if the right side is 'Append',+-- then the right is appended to the left.  If the right side is+-- 'Set', then the left side is ignored.++data SetAppend a = Set a | Append a+    deriving (Eq, Show)++instance Monoid a => SG.Semigroup (SetAppend a) where+   Set    x <> Append y = Set    (x `mappend` y)+   Append x <> Append y = Append (x `mappend` y)+   _        <> Set y    = Set y++instance Monoid a => Monoid (SetAppend a) where+   mempty  = Append mempty+   mappend = (SG.<>)++-- | Extract the value from a 'SetAppend'.+-- Note that a 'SetAppend' is actually a @CoPointed@ from:+-- <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 :: Lazy.WriterT (FilterFun a) m b }+   deriving (Functor, Applicative, Monad, MonadTrans)++instance MonadCatch m => MonadCatch (FilterT a m) where+    catch action handle = FilterT $ catch (unFilterT action) (unFilterT . handle)++instance MonadThrow m => MonadThrow (FilterT a m) where+    throwM = FilterT . throwM++instance MonadBase b m => MonadBase b (FilterT a m) where+    liftBase = lift . liftBase++instance (MonadIO m) => MonadIO (FilterT a m) where+    liftIO = FilterT . liftIO+    {-# INLINE liftIO #-}++instance MonadTransControl (FilterT a) where+    type StT (FilterT a) b = StT (Lazy.WriterT (FilterFun a)) b+    liftWith f = FilterT $ liftWith $ \run -> f $ run . unFilterT+    restoreT = FilterT . restoreT++instance MonadBaseControl b m => MonadBaseControl b (FilterT a m) where+    type StM (FilterT a m) c = ComposeSt (FilterT a) m c+    liftBaseWith = defaultLiftBaseWith+    restoreM     = defaultRestoreM++-- | A set of functions for manipulating filters.+--+-- 'ServerPartT' implements 'FilterMonad' 'Response' so these methods+-- are the fundamental ways of manipulating 'Response' values.+class Monad m => FilterMonad a m | m->a where+    -- | Ignores all previous alterations to your filter+    --+    -- As an example:+    --+    -- > do+    -- >   composeFilter f+    -- >   setFilter g+    -- >   return "Hello World"+    --+    -- The @'setFilter' g@ will cause the first @'composeFilter' f@ to+    -- be ignored.+    setFilter :: (a->a) -> m ()+    -- | Composes your filter function with the existing filter+    -- function.+    composeFilter :: (a->a) -> m ()+    -- | Retrieves the filter from the environment.+    getFilter :: m b -> m (b, a->a)++-- | Resets all your filters. An alias for @'setFilter' 'id'@.+ignoreFilters :: (FilterMonad a m) => m ()+ignoreFilters = setFilter id++instance (Monad m) => FilterMonad a (FilterT a m) where+    setFilter     = FilterT . tell                . Set    . Dual . Endo+    composeFilter = FilterT . tell                . Append . Dual . Endo+    getFilter     = FilterT . listens unFilterFun . unFilterT++-- | The basic 'Response' building object.+newtype WebT m a = WebT { unWebT :: ExceptT Response (FilterT (Response) (MaybeT m)) a }+    deriving (Functor)++instance MonadCatch m => MonadCatch (WebT m) where+    catch action handle = WebT $ catch (unWebT action) (unWebT . handle)++instance MonadThrow m => MonadThrow (WebT m) where+    throwM = WebT . throwM++instance MonadBase b m => MonadBase b (WebT m) where+    liftBase = lift . liftBase++instance (MonadIO m) => MonadIO (WebT m) where+    liftIO = WebT . liftIO+    {-# INLINE liftIO #-}++instance MonadTransControl WebT where+    type StT WebT a = StT MaybeT+                       (StT (FilterT Response)+                        (StT (ExceptT Response) a))+    liftWith f = WebT $ liftWith $ \runError ->+                          liftWith $ \runFilter ->+                            liftWith $ \runMaybe ->+                              f $ runMaybe .+                                   runFilter .+                                    runExceptT . unWebT+    restoreT = WebT . restoreT . restoreT . restoreT++instance MonadBaseControl b m => MonadBaseControl b (WebT m) where+    type StM (WebT m) a = ComposeSt WebT m a+    liftBaseWith = defaultLiftBaseWith+    restoreM     = defaultRestoreM++-- | 'UnWebT' is almost exclusively used with 'mapServerPartT'. If you+-- are not using 'mapServerPartT' then you do not need to wrap your+-- head around this type. If you are -- the type is not as complex as+-- it first appears.+--+-- It is worth discussing the unpacked structure of 'WebT' a bit as+-- it's exposed in 'mapServerPartT' and 'mapWebT'.+--+--  A fully unpacked 'WebT' has a structure that looks like:+--+--  > ununWebT $ WebT m a :: m (Maybe (Either Response a, FilterFun Response))+--+--  So, ignoring @m@, as it is just the containing 'Monad', the+--  outermost layer is a 'Maybe'.  This is 'Nothing' if 'mzero' was+--  called or @'Just' ('Either' 'Response' a, 'SetAppend' ('Endo'+--  'Response'))@ if 'mzero' wasn't called.  Inside the 'Maybe', there+--  is a pair.  The second element of the pair is our filter function+--  @'FilterFun' 'Response'@.  @'FilterFun' 'Response'@ is a type+--  alias for @'SetAppend' ('Dual' ('Endo' 'Response'))@.  This is+--  just a wrapper for a @'Response' -> 'Response'@ function with a+--  particular 'Monoid' behavior.  The value+--+--  >  Append (Dual (Endo f))+--+--  Causes @f@ to be composed with the previous filter.+--+--  >  Set (Dual (Endo f))+--+--  Causes @f@ to not be composed with the previous filter.+--+--  Finally, the first element of the pair is either @'Left'+--  'Response'@ or @'Right' a@.+--+--  Another way of looking at all these pieces is from the behaviors+--  they control.  The 'Maybe' controls the 'mzero' behavior.  @'Set'+--  ('Endo' f)@ comes from the 'setFilter' behavior.  Likewise,+--  @'Append' ('Endo' f)@ is from 'composeFilter'.  @'Left'+--  'Response'@ is what you get when you call 'finishWith' and+--  @'Right' a@ is the normal exit.+--+--  An example case statement looks like:+--+--  >  ex1 webt = do+--  >    val <- ununWebT webt+--  >    case val of+--  >        Nothing -> Nothing  -- this is the interior value when mzero was used+--  >        Just (Left r, f) -> Just (Left r, f) -- r is the value that was passed into "finishWith"+--  >                                             -- f is our filter function+--  >        Just (Right a, f) -> Just (Right a, f) -- a is our normal monadic value+--  >                                               -- f is still our filter function+--+type UnWebT m a = m (Maybe (Either Response a, FilterFun Response))++instance Monad m => Monad (WebT m) where+    m >>= f = WebT $ unWebT m >>= unWebT . f+    {-# INLINE (>>=) #-}+    return a = WebT $ return a+    {-# INLINE return #-}++#if MIN_VERSION_base(4,9,0)+instance MonadFail m => MonadFail (WebT m) where+#endif++    fail s = lift (Fail.fail s)++-- | 'WebMonad' provides a means to end the current computation+-- and return a 'Response' immediately.  This provides an+-- alternate escape route.  In particular it has a monadic value+-- of any type.  And unless you call @'setFilter' 'id'@ first your+-- response filters will be applied normally.+--+-- Extremely useful when you're deep inside a monad and decide+-- that you want to return a completely different content type,+-- since it doesn't force you to convert all your return types to+-- 'Response' early just to accommodate this.+--+-- see also: 'escape' and 'escape''+class Monad m => WebMonad a m | m->a where+    -- abort the current computation and return a value+    finishWith :: a -- ^ value to return (For 'ServerPart', 'a' will always be the type 'Response')+               -> m b++-- | Used to ignore all your filters and immediately end the+-- computation.  A combination of 'ignoreFilters' and 'finishWith'.+escape :: (WebMonad a m, FilterMonad a m) => m a -> m b+escape gen = ignoreFilters >> gen >>= finishWith++-- | An alternate form of 'escape' that can be easily used within a do+-- block.+escape' :: (WebMonad a m, FilterMonad a m) => a -> m b+escape' a = ignoreFilters >> finishWith a+++instance (Monad m) => WebMonad Response (WebT m) where+    finishWith r = WebT $ throwError r++instance MonadTrans WebT where+    lift = WebT . lift . lift . lift++instance (Monad m, MonadPlus m) => MonadPlus (WebT m) where+    -- | Aborts a computation.+    --+    -- This is primarily useful because 'msum' will take an array of+    -- 'MonadPlus' and return the first one that isn't 'mzero', which+    -- is exactly the semantics expected from objects that take lists+    -- of 'ServerPartT'.+    mzero = WebT $ lift $ lift $ mzero+    mplus x y =  WebT $ ExceptT $ FilterT $ (lower x) `mplus` (lower y)+        where lower = (unFilterT . runExceptT . unWebT)++instance (Monad m) => FilterMonad Response (WebT m) where+    setFilter f = WebT $ lift $ setFilter $ f+    composeFilter f = WebT . lift . composeFilter $ f+    getFilter     m = WebT $ ExceptT $ liftM lft $ getFilter (runExceptT $ unWebT m)+        where+          lft (Left  r, _) = Left r+          lft (Right a, f) = Right (a, f)++instance (Monad m, MonadPlus m) => SG.Semigroup (WebT m a) where+    (<>) = mplus++instance (Monad m, MonadPlus m) => Monoid (WebT m a) where+    mempty  = mzero+    mappend = (SG.<>)++-- | For when you really need to unpack a 'WebT' entirely (and not+-- just unwrap the first layer with 'unWebT').+ununWebT :: WebT m a -> UnWebT m a+ununWebT = runMaybeT . Lazy.runWriterT . unFilterT . runExceptT . unWebT++-- | For wrapping a 'WebT' back up.  @'mkWebT' . 'ununWebT' = 'id'@+mkWebT :: UnWebT m a -> WebT m a+mkWebT = WebT . ExceptT . FilterT . Lazy.WriterT . MaybeT++-- | See 'mapServerPartT' for a discussion of this function.+mapWebT :: (UnWebT m a -> UnWebT n b)+        -> (  WebT m a ->   WebT n b)+mapWebT f ma = mkWebT $ f (ununWebT ma)++-- | This is kinda like a very oddly shaped 'mapServerPartT' or 'mapWebT'.+-- You probably want one or the other of those.+localContext :: Monad m => (WebT m a -> WebT m' a) -> ServerPartT m a -> ServerPartT m' a+localContext fn hs+    = withRequest $ \rq -> fn (runServerPartT hs rq)++instance (Monad m, Functor m) => Applicative (WebT m) where+    pure = return+    (<*>) = ap++instance (Functor m, MonadPlus m) => Alternative (WebT m) where+    empty = mzero+    (<|>) = mplus++instance MonadReader r m => MonadReader r (WebT m) where+    ask = lift ask+    local fn m = mkWebT $ local fn (ununWebT m)++instance MonadState st m => MonadState st (WebT m) where+    get = lift get+    put = lift . put++instance MonadError e m => MonadError e (WebT m) where+        throwError err = lift $ throwError err+        catchError action handler = mkWebT $ catchError (ununWebT action) (ununWebT . handler)++instance MonadWriter w m => MonadWriter w (WebT m) where+    tell = lift . tell+    listen m = mkWebT $ Writer.listen (ununWebT m) >>= (return . liftWebT)+        where liftWebT (Nothing, _) = Nothing+              liftWebT (Just (Left x,f), _) = Just (Left x,f)+              liftWebT (Just (Right x,f),w) = Just (Right (x,w),f)+    pass m = mkWebT $ ununWebT m >>= liftWebT+        where liftWebT Nothing = return Nothing+              liftWebT (Just (Left x,f)) = return $ Just (Left x, f)+              liftWebT (Just (Right x,f)) = pass (return x)>>= (\a -> return $ Just (Right a,f))++-- | Deprecated: use 'msum'.+multi :: (Monad m, MonadPlus m) => [ServerPartT m a] -> ServerPartT m a+multi = msum+{-# DEPRECATED multi "Use msum instead" #-}++-- | What is this for, exactly?  I don't understand why @Show a@ is+-- even in the context Deprecated: This function appears to do nothing+-- at all. If it use it, let us know why.+debugFilter :: (MonadIO m, Show a) => ServerPartT m a -> ServerPartT m a+debugFilter handle =+    withRequest $ \rq -> do+                    r <- runServerPartT handle rq+                    return r+{-# DEPRECATED debugFilter "This function appears to do nothing." #-}+++-- "Pattern match failure in do expression at src\AppControl.hs:43:24"+-- is converted to:+-- "src\AppControl.hs:43:24: Pattern match failure in do expression"+-- Then we output this to stderr. Help debugging under Emacs console when using GHCi.+-- This is GHC specific, but you may add your favourite compiler here also.+outputTraceMessage :: String -> a -> a+outputTraceMessage s c | "Pattern match failure " `isPrefixOf` s =+    let w = [(k,p) | (i,p) <- zip (tails s) (inits s), Just k <- [stripPrefix " at " i]]+        v = concatMap (\(k,p) -> k ++ ": " ++ p) w+    in trace v c+outputTraceMessage s c = trace s c+++mkFailMessage :: (FilterMonad Response m, WebMonad Response m) => String -> m b+mkFailMessage s = do+    ignoreFilters+    finishWith (failResponse s)++failResponse :: String -> Response+failResponse s =+    setHeader "Content-Type" "text/html; charset=UTF-8" $+     resultBS 500 (LU.fromString (failHtml s))++failHtml:: String->String+failHtml errString =+   "<!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]++------------------------------------------------------------------------------+-- ServerMonad, FilterMonad, and WebMonad instances for ReaderT, StateT,+-- WriterT, RWST, and ErrorT+------------------------------------------------------------------------------++-- ReaderT++instance (ServerMonad m) => ServerMonad (ReaderT r m) where+    askRq         = lift askRq+    localRq f     = mapReaderT (localRq f)++instance (FilterMonad res m) => FilterMonad res (ReaderT r m) where+    setFilter f   = lift $ setFilter f+    composeFilter = lift . composeFilter+    getFilter     = mapReaderT getFilter++instance (WebMonad a m) => WebMonad a (ReaderT r m) where+    finishWith    = lift . finishWith++-- StateT++instance (ServerMonad m) => ServerMonad (Lazy.StateT s m) where+    askRq         = lift askRq+    localRq f     = Lazy.mapStateT (localRq f)++instance (ServerMonad m) => ServerMonad (Strict.StateT s m) where+    askRq         = lift askRq+    localRq f     = Strict.mapStateT (localRq f)++instance (FilterMonad res m) => FilterMonad res (Lazy.StateT s m) where+    setFilter f   = lift $ setFilter f+    composeFilter = lift . composeFilter+    getFilter   m = Lazy.mapStateT (\m' ->+                                   do ((b,s), f) <- getFilter m'+                                      return ((b, f), s)) m++instance (FilterMonad res m) => FilterMonad res (Strict.StateT s m) where+    setFilter f   = lift $ setFilter f+    composeFilter = lift . composeFilter+    getFilter   m = Strict.mapStateT (\m' ->+                                   do ((b,s), f) <- getFilter m'+                                      return ((b, f), s)) m++instance (WebMonad a m) => WebMonad a (Lazy.StateT s m) where+    finishWith    = lift . finishWith++instance (WebMonad a m) => WebMonad a (Strict.StateT s m) where+    finishWith    = lift . finishWith++-- WriterT++instance (ServerMonad m, Monoid w) => ServerMonad (Lazy.WriterT w m) where+    askRq         = lift askRq+    localRq f     = Lazy.mapWriterT (localRq f)++instance (ServerMonad m, Monoid w) => ServerMonad (Strict.WriterT w m) where+    askRq         = lift askRq+    localRq f     = Strict.mapWriterT (localRq f)++instance (FilterMonad res m, Monoid w) => FilterMonad res (Lazy.WriterT w m) where+    setFilter f   = lift $ setFilter f+    composeFilter = lift . composeFilter+    getFilter   m = Lazy.mapWriterT (\m' ->+                                   do ((b,w), f) <- getFilter m'+                                      return ((b, f), w)) m++instance (FilterMonad res m, Monoid w) => FilterMonad res (Strict.WriterT w m) where+    setFilter f   = lift $ setFilter f+    composeFilter = lift . composeFilter+    getFilter   m = Strict.mapWriterT (\m' ->+                                   do ((b,w), f) <- getFilter m'+                                      return ((b, f), w)) m++instance (WebMonad a m, Monoid w) => WebMonad a (Lazy.WriterT w m) where+    finishWith    = lift . finishWith++instance (WebMonad a m, Monoid w) => WebMonad a (Strict.WriterT w m) where+    finishWith    = lift . finishWith++-- RWST++instance (ServerMonad m, Monoid w) => ServerMonad (Lazy.RWST r w s m) where+    askRq         = lift askRq+    localRq f     = Lazy.mapRWST (localRq f)++instance (ServerMonad m, Monoid w) => ServerMonad (Strict.RWST r w s m) where+    askRq         = lift askRq+    localRq f     = Strict.mapRWST (localRq f)++instance (FilterMonad res m, Monoid w) => FilterMonad res (Lazy.RWST r w s m) where+    setFilter f   = lift $ setFilter f+    composeFilter = lift . composeFilter+    getFilter   m = Lazy.mapRWST (\m' ->+                                   do ((b,s,w), f) <- getFilter m'+                                      return ((b, f), s, w)) m++instance (FilterMonad res m, Monoid w) => FilterMonad res (Strict.RWST r w s m) where+    setFilter f   = lift $ setFilter f+    composeFilter = lift . composeFilter+    getFilter   m = Strict.mapRWST (\m' ->+                                   do ((b,s,w), f) <- getFilter m'+                                      return ((b, f), s, w)) m++instance (WebMonad a m, Monoid w) => WebMonad a (Lazy.RWST r w s m) where+    finishWith     = lift . finishWith++instance (WebMonad a m, Monoid w) => WebMonad a (Strict.RWST r w s m) where+    finishWith     = lift . finishWith++-- ErrorT++#if !MIN_VERSION_transformers(0,6,0)+instance (Error e, ServerMonad m) => ServerMonad (ErrorT e m) where+    askRq     = lift askRq+    localRq f = mapErrorT $ localRq f++instance (Error e, FilterMonad a m) => FilterMonad a (ErrorT e m) where+    setFilter f   = lift $ setFilter f+    composeFilter = lift . composeFilter+    getFilter m = mapErrorT (\m' ->+                                 do (eb, f) <- getFilter m'+                                    case eb of+                                      (Left e)  -> return (Left e)+                                      (Right b) -> return $ Right (b, f)+                  ) m++instance (Error e, WebMonad a m) => WebMonad a (ErrorT e m) where+    finishWith    = lift . finishWith+#endif++-- ExceptT++instance ServerMonad m => ServerMonad (ExceptT e m) where+    askRq     = lift askRq+    localRq f = mapExceptT $ localRq f++instance (FilterMonad a m) => FilterMonad a (ExceptT e m) where+    setFilter f   = lift $ setFilter f+    composeFilter = lift . composeFilter+    getFilter m = mapExceptT (\m' ->+                                 do (eb, f) <- getFilter m'+                                    case eb of+                                      (Left e)  -> return (Left e)+                                      (Right b) -> return $ Right (b, f)+                  ) m++instance WebMonad a m => WebMonad a (ExceptT e m) where+    finishWith    = lift . finishWith++escapeHTTP :: (ServerMonad m, MonadIO m) =>+              (TimeoutIO -> IO ())+           -> m a+escapeHTTP h = liftIO (throwIO (EscapeHTTP h))
+ src/Happstack/Server/Internal/Multipart.hs view
@@ -0,0 +1,281 @@+module Happstack.Server.Internal.Multipart where++import           Control.Monad                   (MonadPlus(mplus))+import           Data.ByteString.Base64.Lazy+import qualified Data.ByteString.Lazy.Char8      as L+import           Data.ByteString.Lazy.Internal   (ByteString(Chunk, Empty))+import qualified Data.ByteString.Lazy.UTF8       as LU+import qualified Data.ByteString.Char8           as S+import           Data.Maybe                      (fromMaybe)+import           Data.Int                        (Int64)+import           Text.ParserCombinators.Parsec   (parse)+import           Happstack.Server.Internal.Types (Input(..))+import           Happstack.Server.Internal.RFC822Headers+import           System.IO                        (Handle, hClose, openBinaryTempFile)++-- | similar to the normal 'span' function, except the predicate gets the whole rest of the lazy bytestring, not just one character.+--+-- TODO: this function has not been profiled.+spanS :: (L.ByteString -> Bool) -> L.ByteString -> (L.ByteString, L.ByteString)+spanS f cs0 = spanS' 0 cs0+  where spanS' _ Empty = (Empty, Empty)+        spanS' n bs@(Chunk c cs)+            | n >= S.length c =+                let (x, y) = spanS' 0 cs+                in (Chunk c x, y)+            | not (f (Chunk (S.drop n c) cs)) = L.splitAt (fromIntegral n) bs+            | otherwise = (spanS' (n + 1) bs)+{-# INLINE spanS #-}++takeWhileS :: (L.ByteString -> Bool) -> L.ByteString -> L.ByteString+takeWhileS f cs0 = takeWhile' 0 cs0+  where takeWhile' _ Empty = Empty+        takeWhile' n bs@(Chunk c cs)+            | n >= S.length c = Chunk c (takeWhile' 0 cs)+            | not (f (Chunk (S.drop n c) cs)) = (Chunk (S.take n c) Empty)+            | otherwise = takeWhile' (n + 1) bs++crlf :: L.ByteString+crlf = L.pack "\r\n"++crlfcrlf :: L.ByteString+crlfcrlf = L.pack "\r\n\r\n"++blankLine :: L.ByteString+blankLine = L.pack "\r\n\r\n"++dropWhileS :: (L.ByteString -> Bool) -> L.ByteString -> L.ByteString+dropWhileS f cs0 = dropWhile' cs0+    where dropWhile' bs+              | L.null bs  = bs+              | f bs       = dropWhile' (L.drop 1 bs)+              | otherwise  = bs++data BodyPart = BodyPart L.ByteString L.ByteString  -- ^ headers body+    deriving (Eq, Ord, Read, Show)++data Work+    = BodyWork ContentType [(String, String)] L.ByteString+    | HeaderWork L.ByteString++type InputWorker = Work -> IO InputIter++data InputIter+    = Failed (Maybe (String, Input)) String+    | BodyResult (String, Input) InputWorker+    | HeaderResult [Header] InputWorker++type FileSaver = FilePath               -- ^ tempdir+                -> Int64                -- ^ quota+                -> FilePath             -- ^ filename of field+                -> L.ByteString         -- ^ content to save+                -> IO (Bool, Int64 , FilePath)  -- ^ truncated?, saved bytes, saved filename++defaultFileSaver :: FilePath -> Int64 -> FilePath -> ByteString -> IO (Bool, Int64, FilePath)+defaultFileSaver tmpDir diskQuota filename b+  | pathSeparator filename = error ("Filename contains path separators: " ++ show filename)+  | otherwise =+    do (fn, h) <- openBinaryTempFile tmpDir filename+       (trunc, len) <- hPutLimit diskQuota h b+       hClose h+       return (trunc, len, fn)+ where+   pathSeparator :: String -> Bool+   pathSeparator template = any (\x-> x == '/' || x == '\\') template++defaultInputIter :: FileSaver -> FilePath -> Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> Work -> IO InputIter+defaultInputIter fileSaver tmpDir diskCount ramCount headerCount maxDisk maxRAM maxHeader (BodyWork ctype ps b)+    | diskCount > maxDisk = return $ Failed Nothing ("diskCount (" ++ show diskCount ++ ") is greater than maxDisk (" ++ show maxDisk  ++ ")")+    | ramCount  > maxRAM  = return $ Failed Nothing ("ramCount ("  ++ show ramCount  ++ ") is greater than maxRAM ("  ++ show maxRAM   ++ ")")+    | otherwise =+        case lookup "filename" ps of+          Nothing ->+              let (b',rest) = L.splitAt (maxRAM - ramCount) b+                  input = (fromMaybe "" $ lookup "name" ps+                          , Input { inputValue       = (Right b')+                                  , inputFilename    = Nothing+                                  , inputContentType = ctype })+              in if L.null rest+                  then return $ BodyResult input (defaultInputIter fileSaver tmpDir diskCount (ramCount + L.length b) headerCount maxDisk maxRAM maxHeader)+                  else return $ Failed (Just input) ("Reached RAM quota of " ++ show maxRAM ++ " bytes.")++          (Just filename) ->+              do (trunc, len, fn) <- fileSaver tmpDir (maxDisk - diskCount) filename b+                 let input = ( fromMaybe "" $ lookup "name" ps+                             , Input { inputValue       = Left fn+                                     , inputFilename    = (Just filename)+                                     , inputContentType = ctype })+                 if trunc+                    then return $ Failed (Just input) ("Reached disk quota of " ++ show maxDisk ++ " bytes.")+                    else return $ BodyResult input (defaultInputIter fileSaver tmpDir (diskCount + len) ramCount headerCount maxDisk maxRAM maxHeader)++defaultInputIter fileSaver tmpDir diskCount ramCount headerCount maxDisk maxRAM maxHeader (HeaderWork bs) =+    case L.splitAt (maxHeader - headerCount) bs of+      (_hs, rest)+          | not (L.null rest) -> return $ Failed Nothing ("Reached header quota of " ++ show maxHeader ++ " bytes.")+          | otherwise ->+              case parse pHeaders (LU.toString bs) (LU.toString bs) of+                (Left e) -> return $ Failed Nothing (show e)+                (Right hs) ->+                    return $ HeaderResult hs+                               (defaultInputIter fileSaver tmpDir diskCount ramCount (headerCount + (L.length bs)) maxDisk maxRAM maxHeader)+{-# INLINE defaultInputIter #-}++hPutLimit :: Int64 -> Handle -> L.ByteString -> IO (Bool, Int64)+hPutLimit maxCount h bs = hPutLimit' maxCount h 0 bs+{-# INLINE hPutLimit #-}++hPutLimit' :: Int64 -> Handle -> Int64 -> L.ByteString -> IO (Bool, Int64)+hPutLimit' _maxCount _h count Empty = return (False, count)+hPutLimit'  maxCount h  count (Chunk c cs)+    | (count + fromIntegral (S.length c)) > maxCount =+        do S.hPut h (S.take (fromIntegral (maxCount - count)) c)+           return (True, maxCount)+    | otherwise =+        do S.hPut h c+           hPutLimit' maxCount h (count + fromIntegral (S.length c)) cs+{-# INLINE hPutLimit' #-}++-- FIXME: can we safely use L.unpack, or do we need to worry about encoding issues in the headers?+bodyPartToInput :: InputWorker -> BodyPart -> IO InputIter -- (Either String (String,Input))+bodyPartToInput inputWorker (BodyPart rawHS b) =+    do r <- inputWorker (HeaderWork rawHS)+       case r of+         (Failed i e) -> return $ Failed i e+         (HeaderResult hs cont) ->+          let ctype = fromMaybe defaultInputType (getContentType hs) in+          case getContentDisposition hs of+              Just (ContentDisposition "form-data" ps) -> do+                  let eb' = case getContentTransferEncoding hs of+                            Nothing -> Right b+                            Just (ContentTransferEncoding "7bit") ->+                                -- We don't bother checking that the data+                                -- really is 7bit-only+                                Right b+                            Just (ContentTransferEncoding "8bit") ->+                                Right b+                            Just (ContentTransferEncoding "binary") ->+                                Right b+                            Just (ContentTransferEncoding "base64") ->+                                Right $ decodeLenient b+                            -- TODO: Support quoted-printable+                            Just cte ->+                                Left ("Bad content-transfer-encoding: " ++ show cte)+                  case eb' of+                      Right b' ->+                          cont (BodyWork ctype ps b')+                      Left err ->+                          return $ Failed Nothing err+              cd -> return $ Failed Nothing ("Expected content-disposition: form-data but got " ++ show cd)+         (BodyResult {}) -> return $ Failed Nothing "bodyPartToInput: Got unexpected BodyResult."++bodyPartsToInputs :: InputWorker -> [BodyPart] -> IO ([(String,Input)], Maybe String)+bodyPartsToInputs _ [] =+    return ([], Nothing)+bodyPartsToInputs inputWorker (b:bs) =+    do r <- bodyPartToInput inputWorker b+       case r of+         (Failed mInput e) ->+             case mInput of+               Nothing  -> return ([], Just e)+               (Just i) -> return ([i], Just e)+         (BodyResult i cont) ->+             do (is, err) <- bodyPartsToInputs cont bs+                return (i:is, err)+         (HeaderResult _ _) ->+             return ([], Just "InputWorker is broken. Returned a HeaderResult when a BodyResult was required.")++multipartBody :: InputWorker -> L.ByteString -> L.ByteString -> IO ([(String, Input)], Maybe String)+multipartBody inputWorker boundary s =+    do let (bodyParts, mErr) = parseMultipartBody boundary s+       (inputs, mErr2) <- bodyPartsToInputs inputWorker bodyParts+       return (inputs, mErr2 `mplus` mErr)++-- | Packs a string into an Input of type "text/plain"+simpleInput :: String -> Input+simpleInput v+    = Input { inputValue       = Right (L.pack v)+            , inputFilename    = Nothing+            , inputContentType = defaultInputType+            }++-- | The default content-type for variables.+defaultInputType :: ContentType+defaultInputType = ContentType "text" "plain" [] -- FIXME: use some default encoding?++parseMultipartBody :: L.ByteString -> L.ByteString -> ([BodyPart], Maybe String)+parseMultipartBody boundary s =+    case dropPreamble boundary s of+      (_partData, Just e)  -> ([], Just e)+      (partData,  Nothing) -> splitParts boundary partData++dropPreamble :: L.ByteString -> L.ByteString -> (L.ByteString, Maybe String)+dropPreamble b s | isBoundary b s = (dropLine s, Nothing)+                 | L.null s = (s, Just $ "Boundary " ++ L.unpack b ++ " not found.")+                 | otherwise = dropPreamble b (dropLine s)++dropLine :: L.ByteString -> L.ByteString+dropLine = L.drop 2 . dropWhileS (not . L.isPrefixOf crlf)++-- | Check whether a string starts with two dashes followed by+--   the given boundary string.+isBoundary :: L.ByteString -- ^ The boundary, without the initial dashes+           -> L.ByteString+           -> Bool+isBoundary b s = startsWithDashes s && b `L.isPrefixOf` L.drop 2 s++-- | Checks whether a string starts with two dashes.+startsWithDashes :: L.ByteString -> Bool+startsWithDashes s = L.pack "--" `L.isPrefixOf` s++splitParts :: L.ByteString -> L.ByteString -> ([BodyPart], Maybe String)+splitParts boundary s =+--    | not (isBoundary boundary s) = ([], Just $ "Missing boundary: " ++ L.unpack boundary ++ "\n" ++ L.unpack s)+    case L.null s of+      True -> ([], Nothing)+      False ->+          case splitPart boundary s of+            (p, s') ->+                let (ps,e) = splitParts boundary s'+                in (p:ps, e)+{-# INLINE splitParts #-}++splitPart :: L.ByteString -> L.ByteString -> (BodyPart, L.ByteString)+splitPart boundary s =+    case splitBlank s of+      (headers, rest) ->+          case splitBoundary boundary (L.drop 4 rest) of+            (body, rest') -> (BodyPart (L.append headers crlf) body, rest')+{-# INLINE splitPart #-}+++splitBlank :: L.ByteString -> (L.ByteString, L.ByteString)+splitBlank s = spanS (not . L.isPrefixOf crlfcrlf) s+{-# INLINE splitBlank #-}+++splitBoundary :: L.ByteString -> L.ByteString -> (L.ByteString, L.ByteString)+splitBoundary boundary s =+    case spanS (not . L.isPrefixOf (L.pack "\r\n--" `L.append` boundary)) s of+      (x,y) | (L.pack "\r\n--" `L.append` boundary `L.append` (L.pack "--"))+                `L.isPrefixOf` y -> (x, L.empty)+            | otherwise -> (x, dropLine (L.drop 2 y))+{-# INLINE splitBoundary #-}++splitAtEmptyLine :: L.ByteString -> Maybe (L.ByteString, L.ByteString)+splitAtEmptyLine s =+    case splitBlank s of+      (before, after) | L.null after -> Nothing+                      | otherwise    -> Just (L.append before crlf, L.drop 4 after)+{-# INLINE splitAtEmptyLine #-}++-- | Split a string at the first CRLF. The CRLF is not included+--   in any of the returned strings.+splitAtCRLF :: ByteString -- ^ String to split.+            -> Maybe (ByteString,ByteString)+            -- ^  Returns 'Nothing' if there is no CRLF.+splitAtCRLF s =+    case spanS (not . L.isPrefixOf crlf) s of+      (before, after) | L.null after -> Nothing+                      | otherwise    -> Just (before, L.drop 2 after)+{-# INLINE splitAtCRLF #-}
+ src/Happstack/Server/Internal/RFC822Headers.hs view
@@ -0,0 +1,272 @@+-- #hide++-----------------------------------------------------------------------------+-- |+-- Module      :  Network.CGI.RFC822Headers+-- Copyright   :  (c) Peter Thiemann 2001,2002+--                (c) Bjorn Bringert 2005-2006+--                (c) Lemmih 2007+-- License     :  BSD-style+--+-- Maintainer  :  lemmih@vo.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Parsing of RFC822-style headers (name, value pairs)+-- Partly based on code from WASHMail.+--+-----------------------------------------------------------------------------+module Happstack.Server.Internal.RFC822Headers+    ( -- * Headers+      Header,+      pHeader,+      pHeaders,+      parseHeaders,++      -- * Content-type+      ContentType(..),+      getContentType,+      parseContentType,+      showContentType,++      -- * Content-transfer-encoding+      ContentTransferEncoding(..),+      getContentTransferEncoding,+      parseContentTransferEncoding,++      -- * Content-disposition+      ContentDisposition(..),+      getContentDisposition,+      parseContentDisposition,++      -- * Utilities+      parseM+      ) where++import Control.Monad+import Control.Monad.Fail (MonadFail)+import Data.Char+import Data.List+import Text.ParserCombinators.Parsec++type Header = (String, String)++pHeaders :: Parser [Header]+pHeaders = many pHeader++parseHeaders :: MonadFail m => SourceName -> String -> m [Header]+parseHeaders = parseM pHeaders++pHeader :: Parser Header+pHeader =+    do name <- many1 headerNameChar+       void $ char ':'+       void $ many ws1+       line <- lineString+       void crLf+       extraLines <- many extraFieldLine+       return (map toLower name, concat (line:extraLines))++extraFieldLine :: Parser String+extraFieldLine =+    do sp <- ws1+       line <- lineString+       void $ crLf+       return (sp:line)++--+-- * Parameters (for Content-type etc.)+--++showParameters :: [(String,String)] -> String+showParameters = concatMap f+    where f (n,v) = "; " ++ n ++ "=\"" ++ concatMap esc v ++ "\""+          esc '\\' = "\\\\"+          esc '"'  = "\\\""+          esc c | c `elem` ['\\','"'] = '\\':[c]+                | otherwise = [c]++p_parameter :: Parser (String,String)+p_parameter =+  do void $ lexeme $ char ';'+     p_name <- lexeme $ p_token+     void $ lexeme $ char '='+     -- Workaround for seemingly standardized web browser bug+     -- where nothing is escaped in the filename parameter+     -- of the content-disposition header in multipart/form-data+     let litStr = if p_name == "filename"+                   then choice [ try ((lookAhead $ do+                                        void (literalString >>+                                              p_parameter))+                                     >> literalString)+                               , buggyLiteralString]+                   else literalString+     p_value <- litStr <|> p_token+     return (map toLower p_name, p_value)+++--+-- * Content type+--++-- | A MIME media type value.+--   The 'Show' instance is derived automatically.+--   Use 'showContentType' to obtain the standard+--   string representation.+--   See <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 void $ many ws1+     c_type <- p_token+     void $ lexeme $ char '/'+     c_subtype <- lexeme $ p_token+     c_parameters <- many p_parameter+     return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters++-- | Parse the standard representation of a content-type.+--   If the input cannot be parsed, this function calls+--   'fail' with a (hopefully) informative error message.+parseContentType :: MonadFail m => String -> m ContentType+parseContentType = parseM pContentType "Content-type"++getContentType :: MonadFail m => [Header] -> m ContentType+getContentType hs = lookupM "content-type" hs >>= parseContentType++--+-- * Content transfer encoding+--++data ContentTransferEncoding =+        ContentTransferEncoding String+    deriving (Show, Read, Eq, Ord)++pContentTransferEncoding :: Parser ContentTransferEncoding+pContentTransferEncoding =+  do void $ many ws1+     c_cte <- p_token+     return $ ContentTransferEncoding (map toLower c_cte)++parseContentTransferEncoding :: MonadFail m => String -> m ContentTransferEncoding+parseContentTransferEncoding =+    parseM pContentTransferEncoding "Content-transfer-encoding"++getContentTransferEncoding :: MonadFail m => [Header] -> m ContentTransferEncoding+getContentTransferEncoding hs =+    lookupM "content-transfer-encoding" hs >>= parseContentTransferEncoding++--+-- * Content disposition+--++data ContentDisposition =+        ContentDisposition String [(String, String)]+    deriving (Show, Read, Eq, Ord)++pContentDisposition :: Parser ContentDisposition+pContentDisposition =+  do void $ many ws1+     c_cd <- p_token+     c_parameters <- many p_parameter+     return $ ContentDisposition (map toLower c_cd) c_parameters++parseContentDisposition :: MonadFail m => String -> m ContentDisposition+parseContentDisposition = parseM pContentDisposition "Content-disposition"++getContentDisposition :: MonadFail m => [Header] -> m ContentDisposition+getContentDisposition hs =+    lookupM "content-disposition" hs  >>= parseContentDisposition++--+-- * Utilities+--++parseM :: MonadFail m => Parser a -> SourceName -> String -> m a+parseM p n inp =+  case parse p n inp of+    Left e -> fail (show e)+    Right x -> return x++lookupM :: (MonadFail m, Eq a, Show a) => a -> [(a,b)] -> m b+lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n++--+-- * Parsing utilities+--++-- | RFC 822 LWSP-char+ws1 :: Parser Char+ws1 = oneOf " \t"++lexeme :: Parser a -> Parser a+lexeme p = do x <- p; void $ many ws1; return x++-- | RFC 822 CRLF (but more permissive)+crLf :: Parser String+crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r"++-- | One line+lineString :: Parser String+lineString = many (noneOf "\n\r")++literalString :: Parser String+literalString = do void $ char '\"'+                   str <- many (noneOf "\"\\" <|> quoted_pair)+                   void $ char '\"'+                   return str++-- No web browsers seem to implement RFC 2046 correctly,+-- since they do not escape double quotes and backslashes+-- in the filename parameter in multipart/form-data.+--+-- Note that this eats everything until the last double quote on the line.+buggyLiteralString :: Parser String+buggyLiteralString =+    do void $ char '\"'+       str <- manyTill anyChar (try lastQuote)+       return str+  where lastQuote = do void $ char '\"'+                       notFollowedBy (try (many (noneOf "\"") >> char '\"'))++headerNameChar :: Parser Char+headerNameChar = noneOf "\n\r:"++tspecials, tokenchar :: [Char]+tspecials = "()<>@,;:\\\"/[]?="  -- RFC2045+tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ tspecials++p_token :: Parser String+p_token = many1 (oneOf tokenchar)++text_chars :: [Char]+text_chars = map chr ([1..9] ++ [11,12] ++ [14..127])++p_text :: Parser Char+p_text = oneOf text_chars++quoted_pair :: Parser Char+quoted_pair = do void $ char '\\'+                 p_text
+ src/Happstack/Server/Internal/Socket.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE CPP #-}+module Happstack.Server.Internal.Socket+    ( acceptLite+    , sockAddrToPeer+    ) where++import Data.List (intersperse)+import Data.Word (Word32)+import qualified Network.Socket as S+  ( Socket+  , PortNumber()+  , SockAddr(..)+  , HostName+  , accept+  )+import Numeric (showHex)++type HostAddress = Word32+type HostAddress6 = (Word32, Word32, Word32, Word32)++-- | Converts a HostAddress to a String in dot-decimal notation+showHostAddress :: HostAddress -> String+showHostAddress num = concat [show q1, ".", show q2, ".", show q3, ".", show q4]+  where (num',q1)   = num `quotRem` 256+        (num'',q2)  = num' `quotRem` 256+        (num''',q3) = num'' `quotRem` 256+        (_,q4)      = num''' `quotRem` 256++-- | Converts a IPv6 HostAddress6 to standard hex notation+showHostAddress6 :: HostAddress6 -> String+showHostAddress6 (a,b,c,d) =+  (concat . intersperse ":" . map (flip showHex ""))+    [p1,p2,p3,p4,p5,p6,p7,p8]+  where (a',p2) = a `quotRem` 65536+        (_,p1)  = a' `quotRem` 65536+        (b',p4) = b `quotRem` 65536+        (_,p3)  = b' `quotRem` 65536+        (c',p6) = c `quotRem` 65536+        (_,p5)  = c' `quotRem` 65536+        (d',p8) = d `quotRem` 65536+        (_,p7)  = d' `quotRem` 65536++-- | alternative implementation of accept to work around EAI_AGAIN errors+acceptLite :: S.Socket -> IO (S.Socket, S.HostName, S.PortNumber)+acceptLite sock = do+  (sock', addr) <- S.accept sock+  let (peer, port) = sockAddrToPeer addr+  return (sock', peer, port)++sockAddrToPeer ::  S.SockAddr -> (S.HostName, S.PortNumber)+sockAddrToPeer addr =+  case addr of+    (S.SockAddrInet p ha)      -> (showHostAddress ha, p)+    (S.SockAddrInet6 p _ ha _) -> (showHostAddress6 ha, p)+    _                          -> error "sockAddrToPeer: Unsupported socket type"
+ src/Happstack/Server/Internal/TimeoutIO.hs view
@@ -0,0 +1,23 @@+module Happstack.Server.Internal.TimeoutIO+    ( TimeoutIO(..)+    ) where++import qualified Data.ByteString.Char8          as B+import qualified Data.ByteString.Lazy.Char8     as L+import Happstack.Server.Internal.TimeoutManager (Handle)+import Network.Socket.SendFile                  (ByteCount, Offset)+++-- |TimeoutIO is a record which abstracts out all the network IO+-- functions needed by the request handling loop. This allows use to+-- use the same event loop for handle both http:// and https://.+data TimeoutIO = TimeoutIO+    { toHandle      :: Handle+    , toPutLazy     :: L.ByteString -> IO ()+    , toPut         :: B.ByteString -> IO ()+    , toGet         :: IO (Maybe B.ByteString)+    , toGetContents :: IO L.ByteString+    , toSendFile    :: FilePath -> Offset -> ByteCount -> IO ()+    , toShutdown    :: IO ()+    , toSecure      :: Bool+    }
+ src/Happstack/Server/Internal/TimeoutManager.hs view
@@ -0,0 +1,84 @@+module Happstack.Server.Internal.TimeoutManager+    ( Manager+    , Handle+    , initialize+    , register+    , registerKillThread+    , tickle+    , pause+    , resume+    , cancel+    , forceTimeout+    , forceTimeoutAll+    ) where++import qualified Data.IORef as I+import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)+import Control.Monad (forever)+import qualified Control.Exception as E++-- FIXME implement stopManager++-- | A timeout manager+newtype Manager = Manager (I.IORef [Handle])+data Handle = Handle (I.IORef (IO ())) (I.IORef State)+data State = Active | Inactive | Paused | Canceled++initialize :: Int -> IO Manager+initialize timeout = do+    ref <- I.newIORef []+    _ <- forkIO $ forever $ do+        threadDelay timeout+        ms <- I.atomicModifyIORef ref (\x -> ([], x))+        ms' <- go ms id+        I.atomicModifyIORef ref (\x -> (ms' x, ()))+    return $ Manager ref+  where+    go [] front = return front+    go (m@(Handle onTimeout iactive):rest) front = do+        state <- I.atomicModifyIORef iactive (\x -> (go' x, x))+        case state of+            Inactive -> do+                action <- I.readIORef onTimeout+                action `E.catch` ignoreAll+                go rest front+            Canceled -> go rest front+            _ -> go rest (front . (:) m)+    go' Active = Inactive+    go' x = x++ignoreAll :: E.SomeException -> IO ()+ignoreAll _ = return ()++register :: Manager -> IO () -> IO Handle+register (Manager ref) onTimeout = do+    iactive <- I.newIORef Active+    action  <- I.newIORef onTimeout+    let h = Handle action iactive+    I.atomicModifyIORef ref (\x -> (h : x, ()))+    return h++registerKillThread :: Manager -> IO Handle+registerKillThread m = do+    tid <- myThreadId+    register m $ killThread tid++tickle, pause, resume, cancel :: Handle -> IO ()+tickle (Handle _ iactive) = I.writeIORef iactive $! Active+pause (Handle _ iactive) = I.writeIORef iactive $! Paused+resume = tickle+cancel (Handle action iactive) =+    do I.writeIORef iactive $! Canceled+       I.writeIORef action $! (return ())++forceTimeout :: Handle -> IO ()+forceTimeout (Handle action iactive) =+  do I.writeIORef iactive $! Canceled+     io <- I.atomicModifyIORef action (\io -> (return (), io))+     io `E.catch` ignoreAll++-- | terminate all threads immediately+forceTimeoutAll :: Manager -> IO ()+forceTimeoutAll (Manager ref) =+  do hs <- I.atomicModifyIORef ref (\hs -> ([], hs))+     mapM_ forceTimeout hs
+ src/Happstack/Server/Internal/TimeoutSocket.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}+{- |+-- borrowed from snap-server. Check there periodically for updates.+-}+module Happstack.Server.Internal.TimeoutSocket where++import           Control.Applicative           (pure)+import           Control.Concurrent            (threadWaitWrite)+import           Control.Exception             as E (catch, throw)+import           Control.Monad                 (liftM, when)+import qualified Data.ByteString.Char8         as B+import qualified Data.ByteString.Lazy.Char8    as L+import qualified Data.ByteString.Lazy.Internal as L+import qualified Data.ByteString               as S+import           Network.Socket                (close)+import qualified Network.Socket.ByteString     as N+import qualified Happstack.Server.Internal.TimeoutManager as TM+import           Happstack.Server.Internal.TimeoutIO (TimeoutIO(..))+import           Network.Socket (Socket, ShutdownCmd(..), shutdown)+import           Network.Socket.SendFile (Iter(..), ByteCount, Offset, sendFileIterWith')+import           Network.Socket.ByteString (sendAll)+import           System.IO.Error (isDoesNotExistError, ioeGetErrorType)+import           System.IO.Unsafe (unsafeInterleaveIO)+import           GHC.IO.Exception (IOErrorType(InvalidArgument))++sPutLazyTickle :: TM.Handle -> Socket -> L.ByteString -> IO ()+sPutLazyTickle thandle sock cs =+    do L.foldrChunks (\c rest -> sendAll sock c >> TM.tickle thandle >> rest) (return ()) cs+{-# INLINE sPutLazyTickle #-}++sPutTickle :: TM.Handle -> Socket -> B.ByteString -> IO ()+sPutTickle thandle sock cs =+    do sendAll sock cs+       TM.tickle thandle+       return ()+{-# INLINE sPutTickle #-}++sGet :: TM.Handle+     -> Socket+     -> IO (Maybe B.ByteString)+sGet handle socket =+  do s <- N.recv socket 65536+     TM.tickle handle+     if S.null s+       then pure Nothing+       else pure (Just s)++sGetContents :: TM.Handle+             -> Socket         -- ^ Connected socket+             -> IO L.ByteString  -- ^ Data received+sGetContents handle sock = loop where+  loop = unsafeInterleaveIO $ do+    s <- N.recv sock 65536+    TM.tickle handle+    if S.null s+      then do+        -- 'InvalidArgument' is GHCs code for eNOTCONN (among other+        -- things). Sometimes the other end of socket is closed first+        -- and this end is already disconnected before we do+        -- 'shutdown'. Ignore this exception.+        shutdown sock ShutdownReceive `E.catch`+                    (\e -> when (not (isDoesNotExistError e || ioeGetErrorType e == InvalidArgument)) (throw e))+        return L.Empty+      else L.Chunk s `liftM` loop+++sendFileTickle :: TM.Handle -> Socket -> FilePath -> Offset -> ByteCount -> IO ()+sendFileTickle thandle outs fp offset count =+    sendFileIterWith' (iterTickle thandle) outs fp 65536 offset count++iterTickle :: TM.Handle -> IO Iter -> IO ()+iterTickle thandle =+    iterTickle'+    where+      iterTickle' :: (IO Iter -> IO ())+      iterTickle' iter =+          do r <- iter+             TM.tickle thandle+             case r of+               (Done _) ->+                      return ()+               (WouldBlock _ fd cont) ->+                   do threadWaitWrite fd+                      iterTickle' cont+               (Sent _ cont) ->+                   do iterTickle' cont++timeoutSocketIO :: TM.Handle -> Socket -> TimeoutIO+timeoutSocketIO handle socket =+    TimeoutIO { toHandle      = handle+              , toShutdown    = close socket+              , toPutLazy     = sPutLazyTickle handle socket+              , toGet         = sGet           handle socket+              , toPut         = sPutTickle     handle socket+              , toGetContents = sGetContents   handle socket+              , toSendFile    = sendFileTickle handle socket+              , toSecure      = False+              }
+ src/Happstack/Server/Internal/Types.hs view
@@ -0,0 +1,536 @@+{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, RankNTypes, CPP #-}++module Happstack.Server.Internal.Types+    (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..),+     takeRequestBody, readInputsBody,+     rqURL, mkHeaders,+     getHeader, getHeaderBS, getHeaderUnsafe,+     hasHeader, hasHeaderBS, hasHeaderUnsafe,+     setHeader, setHeaderBS, setHeaderUnsafe,+     addHeader, addHeaderBS, addHeaderUnsafe,+     setRsCode, -- setCookie, setCookies,+     LogAccess, logMAccess, Conf(..), nullConf, result, resultBS,+     redirect, -- redirect_, redirect', redirect'_,+     isHTTP1_0, isHTTP1_1,+     RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength,+     HttpVersion(..), Length(..), Method(..), canHaveBody, Headers, continueHTTP,+     Host, ContentType(..),+     readDec', fromReadS, readM, FromReqURI(..),+     showRsValidator, EscapeHTTP(..)+    ) where+++import Control.Exception (Exception, SomeException)+#if !MIN_VERSION_transformers(0,6,0)+import Control.Monad.Trans.Error (Error(strMsg))+#endif+import Control.Monad.Fail (MonadFail)+import Control.Monad.Trans (MonadIO(liftIO))+import qualified Control.Concurrent.Thread.Group as TG+import Control.Concurrent.MVar+import qualified Data.Map as M+import Data.Data (Data)+import Data.String (fromString)+import Data.Time.Format (FormatTime(..))+import qualified Data.ByteString.Char8 as P+import Data.ByteString.Char8 (ByteString,pack)+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy.UTF8  as LU (fromString)+import Data.Int   (Int8, Int16, Int32, Int64)+import Data.Maybe+import Data.List+import Data.Word  (Word, Word8, Word16, Word32, Word64)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as Lazy+import Happstack.Server.SURI+import Data.Char (toLower)+import Happstack.Server.Internal.RFC822Headers ( ContentType(..) )+import Happstack.Server.Internal.Cookie+import Happstack.Server.Internal.LogFormat (formatRequestCombined)+import Happstack.Server.Internal.TimeoutIO (TimeoutIO)+import Numeric (readDec, readSigned)+import System.Log.Logger (Priority(..), logM)++-- | HTTP version+data HttpVersion = HttpVersion Int Int+             deriving(Read,Eq)++instance Show HttpVersion where+  show (HttpVersion x y) = (show x) ++ "." ++ (show y)++-- | 'True' if 'Request' is HTTP version @1.1@+isHTTP1_1 :: Request -> Bool+isHTTP1_1 rq =+    case rqVersion rq of+      HttpVersion 1 1 -> True+      _               -> False++-- | 'True' if 'Request' is HTTP version @1.0@+isHTTP1_0 :: Request -> Bool+isHTTP1_0 rq =+    case rqVersion rq of+      HttpVersion 1 0 -> True+      _               -> False++-- | Should the connection be used for further messages after this.+-- isHTTP1_0 && hasKeepAlive || isHTTP1_1 && hasNotConnectionClose+--+-- In addition to this rule All 1xx (informational), 204 (no content),+-- and 304 (not modified) responses MUST NOT include a message-body+-- and therefore are eligible for connection keep-alive.+continueHTTP :: Request -> Response -> Bool+continueHTTP rq rs =+    (isHTTP1_0 rq && checkHeaderBS connectionC keepaliveC rq   &&+       (rsfLength (rsFlags rs) == ContentLength || isNoMessageBodyResponse rs)) ||+    (isHTTP1_1 rq && not (checkHeaderBS connectionC closeC rq) &&+       (rsfLength (rsFlags rs) /= NoContentLength || isNoMessageBodyResponse rs))+  where+    isNoMessageBodyCode code = (code >= 100 && code <= 199) || code == 204 || code == 304+    isNoMessageBodyResponse rs' = isNoMessageBodyCode (rsCode rs') && L.null (rsBody rs')++-- | function to log access requests (see also: 'logMAccess')+-- type LogAccess time =+--    (   String  -- ^ host+--     -> String  -- ^ user+--     -> time    -- ^ time+--     -> String  -- ^ requestLine+--     -> Int     -- ^ responseCode+--     -> Integer -- ^ size+--     -> String  -- ^ referer+--     -> String  -- ^ userAgent+--     -> IO ())+type LogAccess time =+    (   String+     -> String+     -> time+     -> String+     -> Int+     -> Integer+     -> String+     -> String+     -> IO ())++-- | HTTP configuration+data Conf = Conf+    { port        :: Int             -- ^ Port for the server to listen on.+    , validator   :: Maybe (Response -> IO Response) -- ^ a function to validate the output on-the-fly+    , logAccess   :: forall t. FormatTime t => Maybe (LogAccess t) -- ^ function to log access requests (see also: 'logMAccess')+    , timeout     :: Int             -- ^ number of seconds to wait before killing an inactive thread+    , threadGroup :: Maybe TG.ThreadGroup -- ^ ThreadGroup for registering spawned threads for handling requests.+    }++-- | Default configuration contains no validator and the port is set to 8000+nullConf :: Conf+nullConf =+    Conf { port        = 8000+         , validator   = Nothing+         , logAccess   = Just logMAccess+         , timeout     = 30+         , threadGroup = Nothing+         }++-- | log access requests using hslogger and apache-style log formatting+--+-- see also: 'Conf'+logMAccess :: forall t. FormatTime t => LogAccess t+logMAccess host user time requestLine responseCode size referer userAgent =+    logM "Happstack.Server.AccessLog.Combined" INFO $ formatRequestCombined host user time requestLine responseCode size referer userAgent++-- | HTTP request method+data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT | PATCH | EXTENSION ByteString+    deriving (Show, Read, Eq, Ord, Data)++-- | Does the method support a message body?+--+-- For extension methods, we assume yes.+canHaveBody :: Method+            -> Bool+canHaveBody POST          = True+canHaveBody PUT           = True+canHaveBody PATCH         = True+canHaveBody DELETE        = True+canHaveBody (EXTENSION _) = True+canHaveBody _             = False++-- | an HTTP header+data HeaderPair = HeaderPair+    { hName :: ByteString     -- ^ header name+    , hValue :: [ByteString]  -- ^ header value (or values if multiple occurances of the header are present)+    }+    deriving (Read,Show)++-- | a Map of HTTP headers+--+-- the Map key is the header converted to lowercase+type Headers = M.Map ByteString HeaderPair -- ^ lowercased name -> (realname, value)++-- | A flag value set in the 'Response' which controls how the+-- @Content-Length@ header is set, and whether *chunked* output+-- encoding is used.+--+-- see also: 'nullRsFlags', 'notContentLength', and 'chunked'+data Length+    = ContentLength             -- ^ automatically add a @Content-Length@ header to the 'Response'+    | TransferEncodingChunked   -- ^ do not add a @Content-Length@ header. Do use @chunked@ output encoding+    | NoContentLength           -- ^ do not set @Content-Length@ or @chunked@ output encoding.+      deriving (Eq, Ord, Read, Show, Enum)++-- | Result flags+data RsFlags = RsFlags+    { rsfLength :: Length+    } deriving (Show, Read)++-- | Default RsFlags: automatically use @Transfer-Encoding: Chunked@.+nullRsFlags :: RsFlags+nullRsFlags = RsFlags { rsfLength = TransferEncodingChunked }++-- | Do not automatically add a Content-Length field to the 'Response'+noContentLength :: Response -> Response+noContentLength res = res { rsFlags = flags } where flags = (rsFlags res) { rsfLength = NoContentLength }++-- | Do not automatically add a Content-Length header. Do automatically use Transfer-Encoding: Chunked+chunked :: Response -> Response+chunked res         = res { rsFlags = flags } where flags = (rsFlags res) { rsfLength = TransferEncodingChunked }++-- | Automatically add a Content-Length header. Do not use Transfer-Encoding: Chunked+contentLength :: Response -> Response+contentLength res   = res { rsFlags = flags } where flags = (rsFlags res) { rsfLength = ContentLength }++-- | a value extract from the @QUERY_STRING@ or 'Request' body+--+-- If the input value was a file, then it will be saved to a temporary file on disk and 'inputValue' will contain @Left pathToTempFile@.+data Input = Input+    { inputValue       :: Either FilePath L.ByteString+    , inputFilename    :: Maybe FilePath+    , inputContentType :: ContentType+    } deriving (Show, Read)++-- | hostname & port+type Host = (String, Int) -- ^ (hostname, port)++-- | an HTTP Response+data Response+    = Response  { rsCode      :: Int+                , rsHeaders   :: Headers+                , rsFlags     :: RsFlags+                , rsBody      :: L.ByteString+                , rsValidator :: Maybe (Response -> IO Response)+                }+    | SendFile  { rsCode      :: Int+                , rsHeaders   :: Headers+                , rsFlags     :: RsFlags+                , rsValidator :: Maybe (Response -> IO Response)+                , sfFilePath  :: FilePath  -- ^ file handle to send from+                , sfOffset    :: Integer   -- ^ offset to start at+                , sfCount     :: Integer    -- ^ number of bytes to send+                }++instance Show Response where+    showsPrec _ res@Response{}  =+        showString   "================== Response ================"                    .+        showString "\nrsCode      = " . shows      (rsCode res)                        .+        showString "\nrsHeaders   = " . shows      (rsHeaders res)                     .+        showString "\nrsFlags     = " . shows      (rsFlags res)                       .+        showString "\nrsBody      = " . shows      (rsBody res)                        .+        showString "\nrsValidator = " . shows      (showRsValidator (rsValidator res))+    showsPrec _ res@SendFile{}  =+        showString   "================== Response ================"                    .+        showString "\nrsCode      = " . shows      (rsCode res)                        .+        showString "\nrsHeaders   = " . shows      (rsHeaders res)                     .+        showString "\nrsFlags     = " . shows      (rsFlags res)                       .+        showString "\nrsValidator = " . shows      (showRsValidator (rsValidator res)) .+        showString "\nsfFilePath  = " . shows      (sfFilePath res)                    .+        showString "\nsfOffset    = " . shows      (sfOffset res)                      .+        showString "\nsfCount     = " . shows      (sfCount res)++showRsValidator :: Maybe (Response -> IO Response) -> String+showRsValidator = maybe "Nothing" (const "Just <function>")++#if !MIN_VERSION_transformers(0,6,0)+-- what should the status code be ?+instance Error Response where+  strMsg str =+      setHeader "Content-Type" "text/plain; charset=UTF-8" $+       result 500 str+#endif++-- | an HTTP request+data Request = Request+    { rqSecure      :: Bool                  -- ^ request uses https:\/\/+    , rqMethod      :: Method                -- ^ request method+    , rqPaths       :: [String]              -- ^ the uri, split on /, and then decoded+    , rqUri         :: String                -- ^ the raw rqUri+    , rqQuery       :: String                -- ^ the QUERY_STRING+    , rqInputsQuery :: [(String,Input)]      -- ^ the QUERY_STRING decoded as key/value pairs+    , rqInputsBody  :: MVar [(String,Input)] -- ^ the request body decoded as key/value pairs (when appropriate)+    , rqCookies     :: [(String,Cookie)]     -- ^ cookies+    , rqVersion     :: HttpVersion           -- ^ HTTP version+    , rqHeaders     :: Headers               -- ^ the HTTP request headers+    , rqBody        :: MVar RqBody           -- ^ the raw, undecoded request body+    , rqPeer        :: Host                  -- ^ (hostname, port) of the client making the request+    }++instance Show Request where+    showsPrec _ rq =+        showString   "================== Request =================" .+        showString "\nrqSecure      = " . shows      (rqSecure rq) .+        showString "\nrqMethod      = " . shows      (rqMethod rq) .+        showString "\nrqPaths       = " . shows      (rqPaths rq) .+        showString "\nrqUri         = " . showString (rqUri rq) .+        showString "\nrqQuery       = " . showString (rqQuery rq) .+        showString "\nrqInputsQuery = " . shows      (rqInputsQuery rq) .+        showString "\nrqInputsBody  = " . showString "<<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)++-- | read the request body inputs+--+-- This will only work if the body inputs have already been decoded. Otherwise it will return Nothing.+readInputsBody :: Request -> IO (Maybe [(String, Input)])+readInputsBody req =+    do mbi <- tryTakeMVar (rqInputsBody req)+       case mbi of+         (Just bi) ->+                do putMVar (rqInputsBody req) bi+                   return (Just bi)+         Nothing -> return Nothing++-- | Converts a Request into a String representing the corresponding URL+rqURL :: Request -> String+rqURL rq = '/':intercalate "/" (rqPaths rq) ++ (rqQuery rq)++-- | a class for working with types that contain HTTP headers+class HasHeaders a where+    updateHeaders :: (Headers->Headers) -> a -> a -- ^ modify the headers+    headers       :: a -> Headers                 -- ^ extract the headers++instance HasHeaders Response where+    updateHeaders f rs = rs {rsHeaders=f $ rsHeaders rs }+    headers            = rsHeaders++instance HasHeaders Request where+    updateHeaders f rq = rq {rqHeaders = f $ rqHeaders rq }+    headers            = rqHeaders++instance HasHeaders Headers where+    updateHeaders f = f+    headers         = id++-- | The body of an HTTP 'Request'+newtype RqBody = Body { unBody :: L.ByteString } deriving (Read, Show)++-- | Sets the Response status code to the provided Int and lifts the computation+-- into a Monad.+setRsCode :: (Monad m) => Int -> Response -> m Response+setRsCode code rs = return rs { rsCode = code }++-- | Takes a list of (key,val) pairs and converts it into Headers.  The+-- keys will be converted to lowercase+mkHeaders :: [(String,String)] -> Headers+mkHeaders hdrs+    = M.fromListWith join [ (P.pack (map toLower key), HeaderPair (P.pack key) [P.pack value]) | (key,value) <- hdrs ]+    where join (HeaderPair key vs1) (HeaderPair _ vs2) = HeaderPair key (vs2++vs1)++--------------------------------------------------------------+-- Retrieving header information+--------------------------------------------------------------++-- | Lookup header value. Key is case-insensitive.+getHeader :: HasHeaders r => String -> r -> Maybe ByteString+getHeader = getHeaderBS . pack++-- | Lookup header value. Key is a case-insensitive bytestring.+getHeaderBS :: HasHeaders r => ByteString -> r -> Maybe ByteString+getHeaderBS = getHeaderUnsafe . P.map toLower++-- | Lookup header value with a case-sensitive key. The key must be lowercase.+getHeaderUnsafe :: HasHeaders r => ByteString -> r -> Maybe ByteString+getHeaderUnsafe key var = listToMaybe =<< fmap hValue (getHeaderUnsafe' key var)++-- | Lookup header with a case-sensitive key. The key must be lowercase.+getHeaderUnsafe' :: HasHeaders r => ByteString -> r -> Maybe HeaderPair+getHeaderUnsafe' key = M.lookup key . headers++--------------------------------------------------------------+-- Querying header status+--------------------------------------------------------------++-- | Returns True if the associated key is found in the Headers.  The lookup+-- is case insensitive.+hasHeader :: HasHeaders r => String -> r -> Bool+hasHeader key r = isJust (getHeader key r)++-- | Acts as 'hasHeader' with ByteStrings+hasHeaderBS :: HasHeaders r => ByteString -> r -> Bool+hasHeaderBS key r = isJust (getHeaderBS key r)++-- | Acts as 'hasHeaderBS' but the key is case sensitive.  It should be+-- in lowercase.+hasHeaderUnsafe :: HasHeaders r => ByteString -> r -> Bool+hasHeaderUnsafe key r = isJust (getHeaderUnsafe' key r)++checkHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> Bool+checkHeaderBS key val = checkHeaderUnsafe (P.map toLower key) (P.map toLower val)++checkHeaderUnsafe :: HasHeaders r => ByteString -> ByteString -> r -> Bool+checkHeaderUnsafe key val r+    = case getHeaderUnsafe key r of+        Just val' | P.map toLower val' == val -> True+        _ -> False+++--------------------------------------------------------------+-- Setting header status+--------------------------------------------------------------++-- | Associates the key/value pair in the headers.  Forces the key to be+-- lowercase.+setHeader :: HasHeaders r => String -> String -> r -> r+setHeader key val = setHeaderBS (pack key) (pack val)++-- | Acts as 'setHeader' but with ByteStrings.+setHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r+setHeaderBS key val = setHeaderUnsafe (P.map toLower key) (HeaderPair key [val])++-- | Sets the key to the HeaderPair.  This is the only way to associate a key+-- with multiple values via the setHeader* functions.  Does not force the key+-- to be in lowercase or guarantee that the given key and the key in the HeaderPair will match.+setHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r+setHeaderUnsafe key val = updateHeaders (M.insert key val)++--------------------------------------------------------------+-- Adding headers+--------------------------------------------------------------++-- | Add a key/value pair to the header.  If the key already has a value+-- associated with it, then the value will be appended.+-- Forces the key to be lowercase.+addHeader :: HasHeaders r => String -> String -> r -> r+addHeader key val = addHeaderBS (pack key) (pack val)++-- | Acts as addHeader except for ByteStrings+addHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r+addHeaderBS key val = addHeaderUnsafe (P.map toLower key) (HeaderPair key [val])++-- | Add a key/value pair to the header using the underlying HeaderPair data+-- type.  Does not force the key to be in lowercase or guarantee that the given key and the key in the HeaderPair will match.+addHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r+addHeaderUnsafe key val = updateHeaders (M.insertWith join key val)+    where join (HeaderPair k vs1) (HeaderPair _ vs2) = HeaderPair k (vs2++vs1)++-- | Creates a Response with the given Int as the status code and the provided+-- String as the body of the Response+result :: Int -> String -> Response+result code = resultBS code . LU.fromString++-- | Acts as 'result' but works with ByteStrings directly.+--+-- By default, Transfer-Encoding: chunked will be used+resultBS :: Int -> L.ByteString -> Response+resultBS code s = Response code M.empty nullRsFlags s Nothing++-- | Sets the Response's status code to the given Int and redirects to the given URI+redirect :: (ToSURI s) => Int -> s -> Response -> Response+redirect c s resp = setHeaderBS locationC (pack (render (toSURI s))) resp{rsCode = c}++-- constants here++-- | @Location@+locationC :: ByteString+locationC   = P.pack "Location"++-- | @close@+closeC :: ByteString+closeC      = P.pack "close"++-- | @Connection@+connectionC :: ByteString+connectionC = P.pack "Connection"++-- | @Keep-Alive@+keepaliveC :: ByteString+keepaliveC  = P.pack "Keep-Alive"++readDec' :: (Num a, Eq a) => String -> a+readDec' s =+  case readDec s of+    [(n,[])] -> n+    _    -> error "readDec' failed."++-- | Read in any monad.+readM :: (MonadFail m, Read t) => String -> m t+readM s = case reads s of+            [(v,"")] -> return v+            _        -> fail "readM: parse error"++-- |convert a 'ReadS a' result to 'Maybe a'+fromReadS :: [(a, String)] -> Maybe a+fromReadS [(n,[])] = Just n+fromReadS _        = Nothing++-- | This class is used by 'path' to parse a path component into a+-- value.+--+-- The instances for number types ('Int', 'Float', etc) use 'readM' to+-- parse the path component.+--+-- The instance for 'String', on the other hand, returns the+-- unmodified path component.+--+-- See the following section of the Happstack Crash Course for+-- detailed instructions using and extending 'FromReqURI':+--+--  <http://www.happstack.com/docs/crashcourse/RouteFilters.html#FromReqURI>++class FromReqURI a where+    fromReqURI :: String -> Maybe a++instance FromReqURI String  where fromReqURI = Just+instance FromReqURI Text.Text where fromReqURI = fmap fromString . fromReqURI+instance FromReqURI Lazy.Text where fromReqURI = fmap fromString . fromReqURI+instance FromReqURI Char    where fromReqURI s = case s of [c] -> Just c ; _ -> Nothing+instance FromReqURI Int     where fromReqURI = fromReadS . readSigned readDec+instance FromReqURI Int8    where fromReqURI = fromReadS . readSigned readDec+instance FromReqURI Int16   where fromReqURI = fromReadS . readSigned readDec+instance FromReqURI Int32   where fromReqURI = fromReadS . readSigned readDec+instance FromReqURI Int64   where fromReqURI = fromReadS . readSigned readDec+instance FromReqURI Integer where fromReqURI = fromReadS . readSigned readDec+instance FromReqURI Word    where fromReqURI = fromReadS . readDec+instance FromReqURI Word8   where fromReqURI = fromReadS . readDec+instance FromReqURI Word16  where fromReqURI = fromReadS . readDec+instance FromReqURI Word32  where fromReqURI = fromReadS . readDec+instance FromReqURI Word64  where fromReqURI = fromReadS . readDec+instance FromReqURI Float   where fromReqURI = readM+instance FromReqURI Double  where fromReqURI = readM+instance FromReqURI Bool    where+  fromReqURI s =+    let s' = map toLower s in+    case s' of+      "0"     -> Just False+      "false" -> Just False+      "1"     -> Just True+      "true"  -> Just True+      _       -> Nothing++------------------------------------------------------------------------------+-- EscapeHTTP - escape hatched use by websockets+------------------------------------------------------------------------------++-- | Escape from the HTTP world and get direct access to the underlying 'TimeoutIO' functions+data EscapeHTTP+  = EscapeHTTP (TimeoutIO -> IO ())++instance Exception EscapeHTTP++instance Show EscapeHTTP where+  show (EscapeHTTP {})         = "<EscapeHTTP _>"
− src/Happstack/Server/JSON.hs 
@@ -1,29 +0,0 @@-module Happstack.Server.JSON where-import Data.Char-import Data.List--data JSON = JBool Bool | JString String | JInt Int | JFloat Float | -            JObj [(String,JSON)] | JList [JSON] | JNull---jInt :: Integral a => a -> JSON-jInt = JInt . fromIntegral--class ToJSON a where-    toJSON::a->JSON-instance ToJSON JSON where toJSON=id--jsonToString :: JSON -> String-jsonToString (JBool bool) = map toLower $ show bool-jsonToString (JString string) = show string-jsonToString (JInt int) = show int-jsonToString (JFloat float) = show float-jsonToString (JObj pairs) = '{' : (concat $ (intersperse "," $ map impl pairs) )++"}"-    where-    impl (name,val) = concat [show name,":",jsonToString val]-jsonToString (JList list) = -    '[':(concat $ (intersperse "," $ map jsonToString list)) ++"]"-jsonToString JNull = "null"-type CallBack=String--data JSONCall x = JCall CallBack x
− src/Happstack/Server/MessageWrap.hs 
@@ -1,99 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--module Happstack.Server.MessageWrap where--import Control.Monad.Identity-import qualified Data.ByteString.Char8 as P-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.List as List-import Data.Maybe-import Happstack.Server.HTTP.Types as H-import Happstack.Server.HTTP.Multipart-import Happstack.Server.SURI as SURI-import Happstack.Util.Common--queryInput :: SURI -> [(String, Input)]-queryInput uri = formDecode (case SURI.query $ uri of-                               '?':r -> r-                               xs    -> xs)--bodyInput :: Request -> [(String, Input)]-bodyInput req | rqMethod req /= POST = []-bodyInput req =-    let ctype = getHeader "content-type" req >>= parseContentType . P.unpack-        getBS (Body bs) = bs-    in decodeBody ctype (getBS $ rqBody req)----- Decodes application\/x-www-form-urlencoded inputs.      -formDecode :: String -> [(String, Input)]-formDecode [] = []-formDecode qString = -    if null pairString then rest else -           (SURI.unEscape name,simpleInput $ SURI.unEscape val):rest-    where (pairString,qString')= split (=='&') qString-          (name,val)=split (=='=') pairString-          rest=if null qString' then [] else formDecode qString'--decodeBody :: Maybe ContentType-           -> L.ByteString-           -> [(String,Input)]-decodeBody ctype inp-    = case ctype of-        Just (ContentType "application" "x-www-form-urlencoded" _)-            -> formDecode (L.unpack inp)-        Just (ContentType "multipart" "form-data" ps)-            -> multipartDecode ps inp-        Just _ -> [] -- unknown content-type, the user will have to-                     -- deal with it by looking at the raw content-        -- No content-type given, assume x-www-form-urlencoded-        Nothing -> formDecode (L.unpack inp)---- | Decodes multipart\/form-data input.-multipartDecode :: [(String,String)] -- ^ Content-type parameters-                -> L.ByteString        -- ^ Request body-                -> [(String,Input)]  -- ^ Input variables and values.-multipartDecode ps inp =-    case lookup "boundary" ps of-         Just b -> case parseMultipartBody b inp of-                        Just (MultiPart bs) -> map bodyPartToInput bs-                        Nothing -> [] -- FIXME: report parse error-         Nothing -> [] -- FIXME: report that there was no boundary--bodyPartToInput :: BodyPart -> (String,Input)-bodyPartToInput (BodyPart hs b) =-    case getContentDisposition hs of-              Just (ContentDisposition "form-data" ps) ->-                  (fromMaybe "" $ lookup "name" ps,-                   Input { inputValue = b,-                           inputFilename = lookup "filename" ps,-                           inputContentType = ctype })-              _ -> ("ERROR",simpleInput "ERROR") -- FIXME: report error-    where ctype = fromMaybe defaultInputType (getContentType hs)---simpleInput :: String -> Input-simpleInput v-    = Input { inputValue = L.pack v-            , inputFilename = Nothing-            , inputContentType = defaultInputType-            }---- | The default content-type for variables.-defaultInputType :: ContentType-defaultInputType = ContentType "text" "plain" [] -- FIXME: use some default encoding?---- | Get the path components from a String.-pathEls :: String -> [String]-pathEls = (drop 1) . map SURI.unEscape . splitList '/' ---- | Like 'Read' except Strings and Chars not quoted.-class (Read a)=>ReadString a where readString::String->a; readString =read --instance ReadString Int -instance ReadString Double -instance ReadString Float -instance ReadString SURI.SURI where readString = read . show-instance ReadString [Char] where readString=id-instance ReadString Char where -    readString s= if length t==1 then head t else read t where t=trim s
− src/Happstack/Server/MinHaXML.hs 
@@ -1,215 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances,-             OverlappingInstances, UndecidableInstances, TypeSynonymInstances #-}---  -module Happstack.Server.MinHaXML where--- Copyright (c) Happstack.com 2009; (c) HAppS.org 2005. All Rights Reserved.--import Prelude hiding (elem, pi)--import Text.XML.HaXml.Types as Types-import Text.XML.HaXml.Escape-import Text.XML.HaXml.Pretty as Pretty-import Text.XML.HaXml.Verbatim as Verbatim-import Happstack.Util.Common-import Data.Maybe-import System.Time--import Happstack.Data.Xml as Xml-import Happstack.Data.Xml.HaXml--type StyleURL=String-data StyleSheet = NoStyle-                | CSS {styleURL::StyleURL} -                | XSL {styleURL::StyleURL} deriving (Read,Show)-hasStyleURL :: StyleSheet -> Bool-hasStyleURL NoStyle = False-hasStyleURL _ = True -type Element = Types.Element--	--isCSS :: StyleSheet -> Bool-isCSS (CSS _)=True-isCSS _ = False-isXSL :: StyleSheet -> Bool-isXSL = not.isCSS--t :: Name -> [(Name, String)] -> CharData -> Types.Element-t=textElem-l :: Name -> [(Name, String)] -> [Types.Element] -> Types.Element-l=listElem-e :: Name -> [(Name, String)] -> Types.Element-e=emptyElem-(</<) :: Name-         -> [(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)
+ src/Happstack/Server/Monads.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE FlexibleContexts, CPP #-}+-- | This module provides four classes and some related functions+-- which provide 'ServerPartT' with much of its web-centric behavior.+--+--  1. 'ServerMonad' provides access to the HTTP 'Request'+--+--  2. 'FilterMonad' provides the ability to apply filters and transformations to a 'Response'+--+--  3. 'WebMonad' provides a way to escape a computation early and return a 'Response'+--+--  4. 'HasRqData' which provides access to the decoded QUERY_STRING and request body/form data+module Happstack.Server.Monads+    ( -- * ServerPartT+      ServerPartT+    , ServerPart+      -- * Happstack class+    , Happstack+      -- * ServerMonad+    , ServerMonad(..)+    , mapServerPartT+    , mapServerPartT'+    , UnWebT+    , filterFun+      -- * FilterMonad+    , FilterMonad(..)+    , ignoreFilters+    , addHeaderM+    , getHeaderM+    , setHeaderM+    , neverExpires+      -- * WebMonad+    , WebMonad(..)+    , escape+    , escape'+      -- * MonadPlus helpers+    , require+    , requireM+    -- * escapeHTTP+    , escapeHTTP+    ) where++import Control.Applicative               (Alternative, Applicative)+import Control.Monad                     (MonadPlus(mzero))+#if !MIN_VERSION_transformers(0,6,0)+import Control.Monad.Trans.Error         (Error, ErrorT)+#endif+import Control.Monad.Trans               (MonadIO(..),MonadTrans(lift))+import Control.Monad.Trans.Except        (ExceptT)+import Control.Monad.Reader              (ReaderT)+import qualified Control.Monad.Writer.Lazy   as Lazy   (WriterT)+import qualified Control.Monad.Writer.Strict as Strict (WriterT)+import qualified Control.Monad.State.Lazy    as Lazy   (StateT)+import qualified Control.Monad.State.Strict  as Strict (StateT)+import qualified Control.Monad.RWS.Lazy      as Lazy   (RWST)+import qualified Control.Monad.RWS.Strict    as Strict (RWST)+import qualified Data.ByteString.Char8       as B+import Data.Monoid                       (Monoid)+import Happstack.Server.Internal.Monads+import Happstack.Server.Types            (Response, addHeader, getHeader, setHeader)+import Happstack.Server.RqData           (HasRqData)++-- | A class alias for all the classes a standard server monad (such as 'ServerPartT') is expected to have instances for. This allows you to keep your type signatures shorter and easier to understand.+class ( ServerMonad m, WebMonad Response m, FilterMonad Response m+      , MonadIO m, MonadPlus m, HasRqData m, Monad m, Functor m+      , Applicative m, Alternative m) => Happstack m++instance (Functor m, Monad m, MonadPlus m+         , MonadIO m)            => Happstack (ServerPartT m)+instance (Happstack m)           => Happstack (Lazy.StateT        s m)+instance (Happstack m)           => Happstack (Strict.StateT      s m)+instance (Happstack m)           => Happstack (ReaderT        r     m)+instance (Happstack m, Monoid w) => Happstack (Lazy.WriterT   w     m)+instance (Happstack m, Monoid w) => Happstack (Strict.WriterT   w   m)+instance (Happstack m, Monoid w) => Happstack (Lazy.RWST      r w s m)+instance (Happstack m, Monoid w) => Happstack (Strict.RWST    r w s m)+#if !MIN_VERSION_transformers(0,6,0)+instance (Happstack m, Error e)  => Happstack (ErrorT e m)+#endif+instance (Happstack m, Monoid e) => Happstack (ExceptT e m)++-- | Get a header out of the request.+getHeaderM :: (ServerMonad m) => String -> m (Maybe B.ByteString)+getHeaderM a = askRq >>= return . (getHeader a)++-- | Add headers into the response.  This method does not overwrite+-- any existing header of the same name, hence the name 'addHeaderM'.+-- If you want to replace a header use 'setHeaderM'.+addHeaderM :: (FilterMonad Response m) => String -> String -> m ()+addHeaderM a v = composeFilter $ \res-> addHeader a v res++-- | Set a header into the response.  This will replace an existing+-- header of the same name.  Use 'addHeaderM' if you want to add more+-- than one header of the same name.+setHeaderM :: (FilterMonad Response m) => String -> String -> m ()+setHeaderM a v = composeFilter $ \res -> setHeader a v res++-- | Set a far-future Expires header.  Useful for static resources.  If the+-- browser has the resource cached, no extra request is spent.+neverExpires :: (FilterMonad Response m) => m ()+neverExpires = setHeaderM "Expires" "Mon, 31 Dec 2035 12:00:00 GMT"++-- | Run an 'IO' action and, if it returns 'Just', pass it to the+-- second argument.+require :: (MonadIO m, MonadPlus m) => IO (Maybe a) -> (a -> m r) -> m r+require fn handle = do+    mbVal <- liftIO fn+    case mbVal of+        Nothing -> mzero+        Just a -> handle a++-- | A variant of require that can run in any monad, not just 'IO'.+requireM :: (MonadTrans t, Monad m, MonadPlus (t m)) => m (Maybe a) -> (a -> t m r) -> t m r+requireM fn handle = do+    mbVal <- lift fn+    case mbVal of+        Nothing -> mzero+        Just a -> handle a+
− src/Happstack/Server/Parts.hs 
@@ -1,153 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}-module Happstack.Server.Parts(-    compressedResponseFilter-   ,gzipFilter-   ,deflateFilter-   ,encodings-) where-import Happstack.Server.SimpleHTTP-import Text.ParserCombinators.Parsec-import Control.Monad-import Data.Maybe-import Data.List-import qualified Data.ByteString.Char8 as BS-import qualified Codec.Compression.GZip as GZ-import qualified Codec.Compression.Zlib as Z---- | reads the \"Accept-Encoding\" header.  Then, if possible--- will compress the response body with methods "gzip" or "deflate"------ Returns the name of the coding chosen-compressedResponseFilter::-    (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m)-    => m String-compressedResponseFilter = do-    mbAccept<-getHeaderM "Accept-Encoding"-    accept<- maybe mzero return mbAccept-    let eEncoding = bestEncoding $ BS.unpack accept-    (coding,action) <- case eEncoding of-        Left _ -> do-            setResponseCode 406-            finishWith $ toResponse ""-        Right a -> return (a, maybe (fail "Encoding returned not in the list of known encodings")-            id (lookup a allEncodingHandlers))-    setHeaderM "Content-Encoding" coding-    action-    return coding---- | compresses the body of the response with gzip.--- does not set any headers.-gzipFilter::(FilterMonad Response m) => m()-gzipFilter = do-    composeFilter (\r -> r{rsBody = GZ.compress $ rsBody r})---- | compresses the body of the response with zlib's--- deflate method--- does not set any headers.-deflateFilter::(FilterMonad Response m) => m()-deflateFilter = do-    composeFilter (\r -> r{rsBody = Z.compress $ rsBody r})---- | based on the rules describe in rfc2616 sec. 14.3-bestEncoding :: String -> Either String String-bestEncoding encs = do-        encList<-either (Left . show) (Right) $ parse encodings "" encs-        case acceptable encList of-            [] -> Left "no encoding found"-            a -> Right $ head a-    where-        -- first intersect with the list of encodings we know how to deal with at all-        knownEncodings:: [(String,Maybe Double)] -> [(String, Maybe Double)]-        knownEncodings m = intersectBy (\x y->fst x == fst y) m (map (\x -> (x,Nothing)) allEncodings)-        -- this expands the wildcard, by figuring out if we need to include "identity" in the list-        -- Then it deletes the wildcard entry, drops all the "q=0" entries (which aren't allowed).-        ---        -- note this implementation is a little conservative.  if someone were to specify "*"-        -- without a "q" value, it would be this server is willing to accept any format at all.-        -- We pretty much assume we can't send them /any/ format and that they really-        -- meant just "identity" this seems safe to me.-        knownEncodings':: [(String,Maybe Double)] -> [(String, Maybe Double)]-        knownEncodings' m = filter dropZero $ deleteBy (\(a,_) (b,_)->a==b) ("*",Nothing) $-            case lookup "*" (knownEncodings m) of-                Nothing -> addIdent $ knownEncodings m-                Just (Just a) | a>0 -> addIdent $ knownEncodings m-                              | otherwise -> knownEncodings m-                Just (Nothing) -> addIdent $ knownEncodings m-        dropZero (_, Just a) | a==0 = False-                          | otherwise = True-        dropZero (_, Nothing) = True-        addIdent:: [(String,Maybe Double)] -> [(String, Maybe Double)]-        addIdent m = if isNothing $ lookup "identity" m-            then m ++ [("identity",Nothing)]-            else m-        -- finally we sort the list of available encodings.-        acceptable:: [(String,Maybe Double)] -> [String]-        acceptable l = map fst $ sortBy (flip cmp) $  knownEncodings'  l-        -- let the client choose but break ties with gzip-        encOrder = reverse $ zip (reverse allEncodings) [1..]-        m0 = maybe (0.0::Double) id-        cmp (s,mI) (t,mJ) | m0 mI == m0 mJ-            = compare (m0 $ lookup s encOrder) (m0 $ lookup t encOrder)-                          | otherwise = compare (m0 mI) (m0 mJ)---allEncodingHandlers:: (FilterMonad Response m) => [(String, m ())]-allEncodingHandlers = zip allEncodings handlers--allEncodings :: [String]-allEncodings =-    ["gzip"-    ,"x-gzip"---    ,"compress" -- as far as I can tell there is no haskell library that supports this---    ,"x-compress" -- as far as I can tell, there is no haskell library that supports this-    ,"deflate"-    ,"identity"-    ,"*"-    ]--handlers::(FilterMonad Response m) => [m ()]-handlers =-    [gzipFilter-    ,gzipFilter---    ,compressFilter---    ,compressFilter-    ,deflateFilter-    ,return ()-    ,fail $ "chose * as content encoding"-    ]---- | unsupported:  a parser for the Accept-Encoding header-encodings :: GenParser Char st [([Char], Maybe Double)]-encodings = ws >> (encoding1 `sepBy` try sep) >>= (\x -> ws >> eof >> return x)-    where-        ws = many space-        sep = do-            ws-            char ','-            ws-        encoding1 :: GenParser Char st ([Char], Maybe Double)-        encoding1 = do-            encoding <- many1 letter <|> string "*"-            ws-            quality<-optionMaybe qual-            return (encoding, fmap read quality)-        qual = do-            char ';' >> ws >> char 'q' >> ws >> char '=' >> ws-            q<-float-            return $ q-        int = many1 digit-        float = do-                wholePart<-many1 digit-                fractionalPart<-option "" fraction-                return $ wholePart ++ fractionalPart-            <|>-                do-                fractionalPart<-fraction-                return $ fractionalPart-        fraction :: GenParser Char st String-        fraction = do-            char '.'-            fractionalPart<-option "" int-            return $ '.':fractionalPart--
+ src/Happstack/Server/Response.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, ScopedTypeVariables #-}+-- | Functions and classes related to generating a 'Response' and setting the response code. For detailed instruction see the Happstack Crash Course: <http://www.happstack.com/docs/crashcourse/index.html#creating-a-response>+module Happstack.Server.Response+    ( -- * Converting values to a 'Response'+      ToMessage(..)+    , flatten+    , toResponseBS+      -- * Setting the Response Code+    , ok+    , noContent+    , internalServerError+    , badGateway+    , badRequest+    , unauthorized+    , forbidden+    , notFound+    , prettyResponse+    , requestEntityTooLarge+    , seeOther+    , found+    , movedPermanently+    , tempRedirect+    , setResponseCode+    , resp+    -- * Handling if-modified-since+    , ifModifiedSince+    ) where++#if MIN_VERSION_xhtml(3000,3,0)+import qualified Data.ByteString.Builder         as L+#endif+import qualified Data.ByteString.Char8           as B+import qualified Data.ByteString.Lazy.Char8      as L+import qualified Data.ByteString.Lazy.UTF8       as LU (fromString)+import qualified Data.Map                        as M+import qualified Data.Text                       as T+import qualified Data.Text.Encoding              as T+import qualified Data.Text.Lazy                  as LT+import qualified Data.Text.Lazy.Encoding         as LT+import Data.Time                                 (UTCTime, formatTime, defaultTimeLocale)+import           Happstack.Server.Internal.Monads         (FilterMonad(composeFilter))+import           Happstack.Server.Internal.Types+import           Happstack.Server.Types          (Response(..), Request(..), nullRsFlags, getHeader, noContentLength, redirect, result, setHeader, setHeaderBS)+import           Happstack.Server.SURI           (ToSURI)+import qualified Text.Blaze.Html                 as Blaze+import qualified Text.Blaze.Html.Renderer.Utf8   as Blaze+import           Text.Html                       (Html, renderHtml)+import qualified Text.XHtml                      as XHtml (Html, renderHtml)+++-- | A low-level function to build a 'Response' from a content-type+-- and a 'ByteString'.+--+-- Creates a 'Response' in a manner similar to the 'ToMessage' class,+-- but without requiring an instance declaration.+--+-- example:+--+-- > import Data.ByteString.Char8 as C+-- > import Data.ByteString.Lazy.Char8 as L+-- > import Happstack.Server+-- >+-- > main = simpleHTTP nullConf $ ok $ toResponseBS (C.pack "text/plain") (L.pack "hello, world")+--+-- (note: 'C.pack' and 'L.pack' only work for ascii. For unicode strings you would need to use @utf8-string@, @text@, or something similar to create a valid 'ByteString').+toResponseBS :: B.ByteString -- ^ content-type+             -> L.ByteString -- ^ response body+             -> Response+toResponseBS contentType message =+    let res = Response 200 M.empty nullRsFlags message Nothing+    in setHeaderBS (B.pack "Content-Type") contentType res+++-- | 'toResponse' will convert a value into a 'Response' body,+-- set the @content-type@, and set the default response code for that type.+--+-- @happstack-server@ Example:+--+-- > main = simpleHTTP nullConf $ toResponse "hello, world!"+--+-- will generate a 'Response' with the content-type @text/plain@,+-- the response code @200 OK@, and the body: @hello, world!@.+--+-- 'simpleHTTP' will call 'toResponse' automatically, so the above can be shortened to:+--+--  > main = simpleHTTP nullConf $ "hello, world!"+--+-- @happstack-lite@ Example:+--+-- > main = serve Nothing $ toResponse "hello, world!"+--+-- Minimal definition: 'toMessage' (and usually 'toContentType').+class ToMessage a where+    toContentType :: a -> B.ByteString+    toContentType _ = B.pack "text/plain"+    toMessage :: a -> L.ByteString+    toMessage = error "Happstack.Server.SimpleHTTP.ToMessage.toMessage: Not defined"+    toResponse :: a -> Response+    toResponse val =+        let bs = toMessage val+            res = Response 200 M.empty nullRsFlags bs Nothing+        in setHeaderBS (B.pack "Content-Type") (toContentType val)+           res+{-+instance ToMessage [Element] where+    toContentType _ = B.pack "application/xml; charset=UTF-8"+    toMessage [el] = LU.fromString $ H.simpleDoc H.NoStyle $ toHaXmlEl el -- !! OPTIMIZE+    toMessage x    = error ("Happstack.Server.SimpleHTTP 'instance ToMessage [Element]' Can't handle " ++ show x)+-}++instance ToMessage () where+    toContentType _ = B.pack "text/plain"+    toMessage () = L.empty++instance ToMessage String where+    toContentType _ = B.pack "text/plain; charset=UTF-8"+    toMessage = LU.fromString++instance ToMessage T.Text where+    toContentType _ = B.pack "text/plain; charset=UTF-8"+    toMessage t = L.fromChunks [T.encodeUtf8 t]++instance ToMessage LT.Text where+    toContentType _ = B.pack "text/plain; charset=UTF-8"+    toMessage = LT.encodeUtf8++instance ToMessage Integer where+    toMessage = toMessage . show++instance ToMessage a => ToMessage (Maybe a) where+    toContentType _ = toContentType (undefined :: a)+    toMessage Nothing = toMessage "nothing"+    toMessage (Just x) = toMessage x++instance ToMessage Html where+    toContentType _ = B.pack "text/html; charset=UTF-8"+    toMessage = LU.fromString . renderHtml++instance ToMessage XHtml.Html where+    toContentType _ = B.pack "text/html; charset=UTF-8"+#if MIN_VERSION_xhtml(3000,3,0)+    toMessage = L.toLazyByteString . XHtml.renderHtml+#else+    toMessage = LU.fromString . XHtml.renderHtml+#endif+instance ToMessage Blaze.Html where+    toContentType _ = B.pack "text/html; charset=UTF-8"+    toMessage       = Blaze.renderHtml++instance ToMessage Response where+    toResponse = id++instance ToMessage L.ByteString where+    toResponse bs = Response 200 M.empty nullRsFlags bs Nothing++instance ToMessage B.ByteString where+    toResponse bs = toResponse (L.fromChunks [bs])++{-++-- This instances causes awful error messages. I am removing it and+-- seeing if anyone complains. I doubt they will.++instance (Xml a)=>ToMessage a where+    toContentType = toContentType . toXml+    toMessage = toMessage . toPublicXml+-}++--    toMessageM = toMessageM . toPublicXml++-- | alias for: @fmap toResponse@+--+-- turns @m a@ into @m 'Response'@ using 'toResponse'.+--+-- > main = simpleHTTP nullConf $ flatten $ do return "flatten me."+flatten :: (ToMessage a, Functor f) => f a -> f Response+flatten = fmap toResponse+++-- |Honor an @if-modified-since@ header in a 'Request'.+-- If the 'Request' includes the @if-modified-since@ header and the+-- 'Response' has not been modified, then return 304 (Not Modified),+-- otherwise return the 'Response'.+ifModifiedSince :: UTCTime -- ^ mod-time for the 'Response' (MUST NOT be later than server's time of message origination)+                -> Request -- ^ incoming request (used to check for if-modified-since)+                -> Response -- ^ Response to send if there are modifications+                -> Response+ifModifiedSince modTime request response =+    let repr = formatTime defaultTimeLocale "%a, %d %b %Y %X GMT" modTime+        notmodified = getHeader "if-modified-since" request == Just (B.pack $ repr)+    in if notmodified+          then noContentLength $ result 304 "" -- Not Modified+          else setHeader "Last-modified" repr response++-- | Deprecated:  use 'composeFilter'.+modifyResponse :: (FilterMonad a m) => (a -> a) -> m()+modifyResponse = composeFilter+{-# DEPRECATED modifyResponse "Use composeFilter" #-}++-- | Set an arbitrary return code in your response.+--+-- A filter for setting the response code. Generally you will use a+-- helper function like 'ok' or 'seeOther'.+--+-- > main = simpleHTTP nullConf $ do setResponseCode 200+-- >                                 return "Everything is OK"+--+-- see also: 'resp'+setResponseCode :: FilterMonad Response m =>+                   Int -- ^ response code+                -> m ()+setResponseCode code+    = composeFilter $ \r -> r{rsCode = code}++-- | Same as @'setResponseCode' status >> return val@.+--+-- Use this if you want to set a response code that does not already+-- have a helper function.+--+-- > main = simpleHTTP nullConf $ resp 200 "Everything is OK"+resp :: (FilterMonad Response m) =>+        Int -- ^ response code+     -> b   -- ^ value to return+     -> m b+resp status val = setResponseCode status >> return val++-- | Respond with @200 OK@.+--+-- > main = simpleHTTP nullConf $ ok "Everything is OK"+ok :: (FilterMonad Response m) => a -> m a+ok = resp 200++-- | Respond with @204 No Content@+--+-- A @204 No Content@ response may not contain a message-body. If you try to supply one, it will be dutifully ignored.+--+-- > main = simpleHTTP nullConf $ noContent "This will be ignored."+noContent :: (FilterMonad Response m) => a -> m a+noContent val = composeFilter (\r -> noContentLength (r { rsCode = 204, rsBody = L.empty })) >> return val++-- | Respond with @301 Moved Permanently@.+--+-- > main = simpleHTTP nullConf $ movedPermanently "http://example.org/" "What you are looking for is now at http://example.org/"+movedPermanently :: (FilterMonad Response m, ToSURI a) => a -> res -> m res+movedPermanently uri res = do modifyResponse $ redirect 301 uri+                              return res++-- | Respond with @302 Found@.+--+-- You probably want 'seeOther'. This method is not in popular use anymore, and is generally treated like 303 by most user-agents anyway.+found :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res+found uri res = do modifyResponse $ redirect 302 uri+                   return res++-- | Respond with @303 See Other@.+--+-- > main = simpleHTTP nullConf $ seeOther "http://example.org/" "What you are looking for is now at http://example.org/"+--+-- NOTE: The second argument of 'seeOther' is the message body which will sent to the browser. According to the HTTP 1.1 spec,+--+-- @the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s).@+--+-- This is because pre-HTTP\/1.1 user agents do not support 303. However, in practice you can probably just use @\"\"@ as the second argument.+seeOther :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res+seeOther uri res = do modifyResponse $ redirect 303 uri+                      return res++-- | Respond with @307 Temporary Redirect@.+--+-- > main = simpleHTTP nullConf $ tempRedirect "http://example.org/" "What you are looking for is temporarily at http://example.org/"+tempRedirect :: (FilterMonad Response m, ToSURI a) => a -> res -> m res+tempRedirect val res = do modifyResponse $ redirect 307 val+                          return res++-- | Respond with @400 Bad Request@.+--+-- > main = simpleHTTP nullConf $ badRequest "Bad Request."+badRequest :: (FilterMonad Response m) => a -> m a+badRequest = resp 400++-- | Respond with @401 Unauthorized@.+--+-- > main = simpleHTTP nullConf $ unauthorized "You are not authorized."+unauthorized :: (FilterMonad Response m) => a -> m a+unauthorized = resp 401++-- | Respond with @403 Forbidden@.+--+-- > main = simpleHTTP nullConf $ forbidden "Sorry, it is forbidden."+forbidden :: (FilterMonad Response m) => a -> m a+forbidden = resp 403++-- | Respond with @404 Not Found@.+--+-- > main = simpleHTTP nullConf $ notFound "What you are looking for has not been found."+notFound :: (FilterMonad Response m) => a -> m a+notFound = resp 404++-- | Respond with @413 Request Entity Too Large@.+--+-- > main = simpleHTTP nullConf $ requestEntityTooLarge "That's too big for me to handle."+requestEntityTooLarge :: (FilterMonad Response m) => a -> m a+requestEntityTooLarge = resp 413++-- | Respond with @500 Internal Server Error@.+--+-- > main = simpleHTTP nullConf $ internalServerError "Sorry, there was an internal server error."+internalServerError :: (FilterMonad Response m) => a -> m a+internalServerError = resp 500++-- | Responds with @502 Bad Gateway@.+--+-- > main = simpleHTTP nullConf $ badGateway "Bad Gateway."+badGateway :: (FilterMonad Response m) => a -> m a+badGateway = resp 502++-- | A nicely formatted rendering of a 'Response'+prettyResponse :: Response -> String+prettyResponse res@Response{}  =+    showString   "================== Response ================"       .+    showString "\nrsCode      = " . shows      (rsCode res)           .+    showString "\nrsHeaders   = " . shows      (rsHeaders res)        .+    showString "\nrsFlags     = " . shows      (rsFlags res)          .+    showString "\nrsBody      = " . shows      (rsBody res)           .+    showString "\nrsValidator = " $ showRsValidator (rsValidator res)+prettyResponse res@SendFile{}  =+    showString   "================== Response ================"                    .+    showString "\nrsCode      = " . shows      (rsCode res)                        .+    showString "\nrsHeaders   = " . shows      (rsHeaders res)                     .+    showString "\nrsFlags     = " . shows      (rsFlags res)                       .+    showString "\nrsValidator = " . shows      (showRsValidator (rsValidator res)) .+    showString "\nsfFilePath  = " . shows      (sfFilePath res)                    .+    showString "\nsfOffset    = " . shows      (sfOffset res)                      .+    showString "\nsfCount     = " $ show       (sfCount res)
+ src/Happstack/Server/Routing.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE FlexibleInstances, PatternGuards, ScopedTypeVariables, TypeSynonymInstances #-}+-- | Route an incoming 'Request' to a handler. For more in-depth documentation see this section of the Happstack Crash Course: <http://www.happstack.com/docs/crashcourse/index.html#route-filters>+module Happstack.Server.Routing+    ( -- * Route by scheme+      http+    , https+      -- * Route by request method+    , methodM+    , methodOnly+    , methodSP+    , method+    , MatchMethod(..)+      -- * Route by pathInfo+    , dir+    , dirs+    , nullDir+    , trailingSlash+    , noTrailingSlash+    , anyPath+    , path+    , uriRest+    -- * Route by host+    , host+    , withHost+      -- * Route by (Request -> Bool)+    , guardRq+    ) where++import           Control.Monad                    (MonadPlus(mzero), unless)+import qualified Data.ByteString.Char8            as B+import           Happstack.Server.Monads          (ServerMonad(..))+import           Happstack.Server.Types           (Request(..), Method(..), FromReqURI(..), getHeader, rqURL)+import           System.FilePath                  (makeRelative, splitDirectories)++-- | instances of this class provide a variety of ways to match on the 'Request' method.+--+-- Examples:+--+-- > method GET                  -- match GET or HEAD+-- > method [GET, POST]          -- match GET, HEAD or POST+-- > method HEAD                 -- match HEAD /but not/ GET+-- > method (== GET)             -- match GET or HEAD+-- > method (not . (==) DELETE)  -- match any method except DELETE+-- > method ()                   -- match any method+--+-- As you can see, GET implies that HEAD should match as well.  This is to+-- make it harder to write an application that uses HTTP incorrectly.+-- Happstack handles HEAD requests automatically, but we still need to make+-- sure our handlers don't mismatch or a HEAD will result in a 404.+--+-- If you must, you can still do something like this+-- to match GET without HEAD:+--+-- > guardRq ((== GET) . rqMethod)++class MatchMethod m where+    matchMethod :: m -> Method -> Bool++instance MatchMethod Method where+    matchMethod m = matchMethod (== m)++instance MatchMethod [Method] where+    matchMethod ms m = any (`matchMethod` m) ms++instance MatchMethod (Method -> Bool) where+    matchMethod f HEAD = f HEAD || f GET+    matchMethod f m    = f m++instance MatchMethod () where+    matchMethod () _ = True++-------------------------------------+-- guards++-- | Guard using an arbitrary function on the 'Request'.+guardRq :: (ServerMonad m, MonadPlus m) => (Request -> Bool) -> m ()+guardRq f = do+    rq <- askRq+    unless (f rq) mzero+++-- | guard which checks that an insecure connection was made via http:\/\/+--+-- Example:+--+-- > handler :: ServerPart Response+-- > handler =+-- >     do http+-- >        ...+http :: (ServerMonad m, MonadPlus m) => m ()+http = guardRq (not . rqSecure)+++-- | guard which checks that a secure connection was made via https:\/\/+--+-- Example:+--+-- > handler :: ServerPart Response+-- > handler =+-- >     do https+-- >        ...+https :: (ServerMonad m, MonadPlus m) => m ()+https = guardRq rqSecure+++-- | Guard against the method only (as opposed to 'methodM').+--+-- Example:+--+-- > handler :: ServerPart Response+-- > handler =+-- >     do method [GET, HEAD]+-- >        ...+method :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()+method meth = guardRq $ \rq -> matchMethod meth (rqMethod rq)++-- | Guard against the method. This function also guards against+-- *any remaining path segments*. See 'method' for the version+-- that guards only by method.+--+-- Example:+--+-- > handler :: ServerPart Response+-- > handler =+-- >     do methodM [GET, HEAD]+-- >        ...+--+-- NOTE: This function is largely retained for backwards+-- compatibility. The fact that implicitly calls 'nullDir' is often+-- forgotten and leads to confusion. It is probably better to just use+-- 'method' and call 'nullDir' explicitly.+--+-- This function will likely be deprecated in the future.+methodM :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()+methodM meth = methodOnly meth >> nullDir++-- | Guard against the method only (as opposed to 'methodM').+--+-- Example:+--+-- > handler :: ServerPart Response+-- > handler =+-- >     do methodOnly [GET, HEAD]+-- >        ...+methodOnly :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()+methodOnly = method+{-# DEPRECATED methodOnly "this function is just an alias for method now" #-}++-- | Guard against the method. Note, this function also guards against+-- any remaining path segments. Similar to 'methodM' but with a different type signature.+--+-- Example:+--+-- > handler :: ServerPart Response+-- > handler = methodSP [GET, HEAD] $ subHandler+--+-- NOTE: This style of combinator is going to be deprecated in the+-- future. It is better to just use 'method'.+--+-- > handler :: ServerPart Response+-- > handler = method [GET, HEAD] >> nullDir >> subHandler+{-# DEPRECATED methodSP "use method instead." #-}+methodSP :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m b-> m b+methodSP m handle = methodM m >> handle++-- | guard which only succeeds if there are no remaining path segments+--+-- Often used if you want to explicitly assign a route for '/'+--+nullDir :: (ServerMonad m, MonadPlus m) => m ()+nullDir = guardRq $ \rq -> null (rqPaths rq)++-- | Pop a path element and run the supplied handler if it matches the+-- given string.+--+-- > handler :: ServerPart Response+-- > handler = dir "foo" $ dir "bar" $ subHandler+--+-- The path element can not contain \'/\'. See also 'dirs'.+dir :: (ServerMonad m, MonadPlus m) => String -> m a -> m a+dir staticPath handle =+    do+        rq <- askRq+        case rqPaths rq of+            (p:xs) | p == staticPath -> localRq (\newRq -> newRq{rqPaths = xs}) handle+            _ -> mzero++-- | Guard against a 'FilePath'. Unlike 'dir' the 'FilePath' may+-- contain \'/\'. If the guard succeeds, the matched elements will be+-- popped from the directory stack.+--+-- > dirs "foo/bar" $ ...+--+-- See also: 'dir'.+dirs :: (ServerMonad m, MonadPlus m) => FilePath -> m a -> m a+dirs fp m =+     do let parts = splitDirectories (makeRelative "/" fp)+        foldr dir m parts++-- | Guard against the host.+--+-- This matches against the @host@ header specified in the incoming 'Request'.+--+-- Can be used to support virtual hosting, <http://en.wikipedia.org/wiki/Virtual_hosting>+--+-- Note that this matches against the value of the @Host@ header which may include the port number.+--+-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.23>+--+-- see also: 'withHost'+host :: (ServerMonad m, MonadPlus m) => String -> m a -> m a+host desiredHost handle =+    do rq <- askRq+       case getHeader "host" rq of+         (Just hostBS) | desiredHost == B.unpack hostBS -> handle+         _ -> mzero++-- | Lookup the @host@ header in the incoming request and pass it to the handler.+--+-- see also: 'host'+withHost :: (ServerMonad m, MonadPlus m) => (String -> m a) -> m a+withHost handle =+    do rq <- askRq+       case getHeader "host" rq of+         (Just hostBS) -> handle (B.unpack hostBS)+         _ -> mzero+++-- | Pop a path element and parse it using the 'fromReqURI' in the+-- 'FromReqURI' class.+path :: (FromReqURI a, MonadPlus m, ServerMonad m) => (a -> m b) -> m b+path handle = do+    rq <- askRq+    case rqPaths rq of+        (p:xs) | Just a <- fromReqURI p+                            -> localRq (\newRq -> newRq{rqPaths = xs}) (handle a)+        _ -> mzero++-- | Grab the rest of the URL (dirs + query) and passes it to your+-- handler.+uriRest :: (ServerMonad m) => (String -> m a) -> m a+uriRest handle = askRq >>= handle . rqURL++-- | Pop any path element and run the handler.+--+-- Succeeds if a path component was popped. Fails is the remaining path was empty.+anyPath :: (ServerMonad m, MonadPlus m) => m r -> m r+anyPath x = path $ (\(_::String) -> x)++-- | Guard which checks that the Request URI ends in @\'\/\'@.  Useful+-- for distinguishing between @foo@ and @foo/@+trailingSlash :: (ServerMonad m, MonadPlus m) => m ()+trailingSlash = guardRq $ \rq -> (last (rqUri rq)) == '/'++-- | The opposite of 'trailingSlash'.+noTrailingSlash :: (ServerMonad m, MonadPlus m) => m ()+noTrailingSlash = guardRq $ \rq -> (last (rqUri rq)) /= '/'
+ src/Happstack/Server/RqData.hs view
@@ -0,0 +1,720 @@+{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-}+-- | Functions for extracting values from the query string, form data, cookies, etc.+--+-- For in-depth documentation see the following section of the Happstack Crash Course:+--+-- <http://www.happstack.com/docs/crashcourse/index.html#parsing-request-data-from-the-query_string-cookies-and-request-body>+module Happstack.Server.RqData+    ( -- * Looking up keys+      -- ** Form Values and Query Parameters+      look+    , looks+    , lookText+    , lookText'+    , lookTexts+    , lookTexts'+    , lookBS+    , lookBSs+    , lookRead+    , lookReads+    , lookFile+    , lookPairs+    , lookPairsBS+    -- ** Cookies+    , lookCookie+    , lookCookieValue+    , readCookieValue+    -- ** low-level+    , lookInput+    , lookInputs+    -- * Filters+    -- The look* functions normally search the QUERY_STRING and the Request+    -- body for matches keys.+    , body+    , queryString+    , bytestring+    -- * Validation and Parsing+    , checkRq+    , checkRqM+    , readRq+    , unsafeReadRq+    -- * Handling POST\/PUT Requests+    , decodeBody+    -- ** Body Policy+    , BodyPolicy(..)+    , defaultBodyPolicy+    -- * RqData Monad & Error Reporting+    , RqData+    , mapRqData+    , Errors(..)+    -- ** Using RqData with ServerMonad+    , getDataFn+    , withDataFn+    , FromData(..)+    , getData+    , withData+    -- * HasRqData class+    , RqEnv+    , HasRqData(askRqEnv, localRqEnv,rqDataError)+    ) where++import Control.Applicative                      (Applicative((<*>), pure), Alternative((<|>), empty), WrappedMonad(WrapMonad, unwrapMonad))+import Control.Monad                            (MonadPlus(mzero, mplus))+import Control.Monad.Reader                     (ReaderT(ReaderT, runReaderT), MonadReader(ask, local), mapReaderT)+import qualified Control.Monad.State.Lazy as Lazy      (StateT, mapStateT)+import qualified Control.Monad.State.Strict as Strict  (StateT, mapStateT)+import qualified Control.Monad.Writer.Lazy as Lazy     (WriterT, mapWriterT)+import qualified Control.Monad.Writer.Strict as Strict (WriterT, mapWriterT)+import qualified Control.Monad.RWS.Lazy as Lazy        (RWST, mapRWST)+import qualified Control.Monad.RWS.Strict as Strict    (RWST, mapRWST)+#if !MIN_VERSION_transformers(0,6,0)+import qualified Control.Monad.Trans.Error as DeprecatedError+#endif+import Control.Monad.Except                     (throwError)+import Control.Monad.Trans                      (MonadIO(..), lift)+import Control.Monad.Trans.Except               (ExceptT, mapExceptT)+import qualified Data.ByteString.Char8          as P+import qualified Data.ByteString.Lazy.Char8     as L+import qualified Data.ByteString.Lazy.UTF8      as LU+import Data.Char                                (toLower)+import Data.Either                              (partitionEithers)+import Data.Generics                            (Data)+import Data.Maybe                               (fromJust)+import Data.Monoid                              (Monoid(mempty, mappend, mconcat))+import qualified Data.Semigroup                 as SG+import           Data.Text                      (Text)+import qualified Data.Text.Lazy                 as LazyText+import qualified Data.Text.Lazy.Encoding        as LazyText+import Happstack.Server.Cookie                  (Cookie (cookieValue))+import Happstack.Server.Internal.Monads+import Happstack.Server.Types+import Happstack.Server.Internal.MessageWrap    (BodyPolicy(..), bodyInput, defaultBodyPolicy)+import Happstack.Server.Response                (requestEntityTooLarge, toResponse)+import Network.URI                              (unEscapeString)++newtype ReaderError r e a = ReaderError { unReaderError :: ReaderT r (Either e) a }+    deriving (Functor, Monad)++#if MIN_VERSION_transformers(0,6,0)+deriving instance (Monoid e, MonadPlus (Either e)) => MonadPlus (ReaderError r e)+#else+deriving instance (Monoid e, DeprecatedError.Error e, MonadPlus (Either e)) => MonadPlus (ReaderError r e)+#endif++#if MIN_VERSION_transformers(0,6,0)+instance (Monoid e) => MonadReader r (ReaderError r e) where+#else+instance (DeprecatedError.Error e, Monoid e) => MonadReader r (ReaderError r e) where+#endif+    ask = ReaderError ask+    local f m = ReaderError $ local f (unReaderError m)++#if MIN_VERSION_transformers(0,6,0)+instance (Monoid e) => Applicative (ReaderError r e) where+#else+instance (Monoid e, DeprecatedError.Error e) => Applicative (ReaderError r e) where+#endif+    pure = return+    (ReaderError (ReaderT f)) <*> (ReaderError (ReaderT a))+        = ReaderError $ ReaderT $ \env -> (f env) `apEither` (a env)++#if MIN_VERSION_transformers(0,6,0)+instance (MonadPlus (Either e), Monoid e) => Alternative (ReaderError r e) where+#else+instance (Monoid e, DeprecatedError.Error e) => Alternative (ReaderError r e) where+#endif+    empty = unwrapMonad empty+    f <|> g = unwrapMonad $ (WrapMonad f) <|> (WrapMonad g)++apEither :: (Monoid e) => Either e (a -> b) -> Either e a -> Either e b+apEither (Left errs1) (Left errs2) = Left (errs1 `mappend` errs2)+apEither (Left errs)  _            = Left errs+apEither _            (Left errs)  = Left errs+apEither (Right f)    (Right a)    = Right (f a)++-- | a list of errors+newtype Errors a = Errors { unErrors :: [a] }+    deriving (Eq, Ord, Show, Read, Data)++instance SG.Semigroup (Errors a) where+    (Errors x) <> (Errors y) = Errors (x ++ y)++instance Monoid (Errors a) where+    mempty = Errors []+    mappend = (SG.<>)+    mconcat errs = Errors $ concatMap unErrors errs++#if MIN_VERSION_transformers(0,6,0)+instance (Alternative (Either (Errors a))) => MonadPlus (Either (Errors a)) where+  mzero = Left (Errors [])+  (Left _) `mplus` n = n+  m        `mplus` _ = m++instance Alternative (Either (Errors a)) where+  empty = Left (Errors [])+  (Left _) <|> n = n+  m        <|> _ = m+#endif++#if !MIN_VERSION_transformers(0,6,0)+instance DeprecatedError.Error (Errors String) where+    noMsg = Errors []+    strMsg str = Errors [str]+#endif++strMsg :: a -> Errors a+strMsg errMsg = Errors [errMsg]++{- commented out to avoid 'Defined but not used' warning.+readerError :: (Monoid e, Error e) => e -> ReaderError r e b+readerError e = mapReaderErrorT ((Left e) `apEither`) (return ())++mapReaderErrorT :: (Either e a -> Either e' b) -> (ReaderError r e a) -> (ReaderError r e' b)+mapReaderErrorT f m = ReaderError $ mapReaderT f (unReaderError m)+-}++runReaderError :: ReaderError r e a -> r -> Either e a+runReaderError = runReaderT . unReaderError++-- | the environment used to lookup query parameters. It consists of+-- the triple: (query string inputs, body inputs, cookie inputs)+type RqEnv = ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)])++-- | An applicative functor and monad for looking up key/value pairs+-- in the QUERY_STRING, Request body, and cookies.+newtype RqData a = RqData { unRqData :: ReaderError RqEnv (Errors String) a }+    deriving (Functor, Monad, MonadPlus, Applicative, Alternative, MonadReader RqEnv )++-- | A class for monads which contain a 'RqEnv'+class HasRqData m where+    askRqEnv :: m RqEnv+    localRqEnv :: (RqEnv -> RqEnv) -> m a -> m a+    -- | lift some 'Errors' into 'RqData'+    rqDataError :: Errors String -> m a++instance HasRqData RqData where+    askRqEnv    = RqData ask+    localRqEnv f (RqData re) = RqData $ local f re+    rqDataError e = mapRqData ((Left e) `apEither`) (return ())++-- instance (MonadPlus m, MonadIO m, ServerMonad m) => (HasRqData m) where+instance (MonadIO m, MonadPlus m) => HasRqData (ServerPartT m) where+    askRqEnv = smAskRqEnv+    rqDataError _e = mzero+    localRqEnv = smLocalRqEnv++------------------------------------------------------------------------------+-- HasRqData instances for ReaderT, StateT, WriterT, RWST, and ErrorT+------------------------------------------------------------------------------++instance (Monad m, HasRqData m) => HasRqData (ReaderT s m) where+    askRqEnv      = lift askRqEnv+    localRqEnv f  = mapReaderT (localRqEnv f)+    rqDataError e = lift (rqDataError e)++instance (Monad m, HasRqData m) => HasRqData (Lazy.StateT s m) where+    askRqEnv      = lift askRqEnv+    localRqEnv f  = Lazy.mapStateT (localRqEnv f)+    rqDataError e = lift (rqDataError e)++instance (Monad m, HasRqData m) => HasRqData (Strict.StateT s m) where+    askRqEnv      = lift askRqEnv+    localRqEnv f  = Strict.mapStateT (localRqEnv f)+    rqDataError e = lift (rqDataError e)++instance (Monad m, HasRqData m, Monoid w) => HasRqData (Lazy.WriterT w m) where+    askRqEnv      = lift askRqEnv+    localRqEnv f  = Lazy.mapWriterT (localRqEnv f)+    rqDataError e = lift (rqDataError e)++instance (Monad m, HasRqData m, Monoid w) => HasRqData (Strict.WriterT w m) where+    askRqEnv      = lift askRqEnv+    localRqEnv f  = Strict.mapWriterT (localRqEnv f)+    rqDataError e = lift (rqDataError e)++instance (Monad m, HasRqData m, Monoid w) => HasRqData (Lazy.RWST r w s m) where+    askRqEnv      = lift askRqEnv+    localRqEnv f  = Lazy.mapRWST (localRqEnv f)+    rqDataError e = lift (rqDataError e)++instance (Monad m, HasRqData m, Monoid w) => HasRqData (Strict.RWST r w s m) where+    askRqEnv      = lift askRqEnv+    localRqEnv f  = Strict.mapRWST (localRqEnv f)+    rqDataError e = lift (rqDataError e)++#if !MIN_VERSION_transformers(0,6,0)+instance (Monad m, DeprecatedError.Error e, HasRqData m) => HasRqData (DeprecatedError.ErrorT e m) where+    askRqEnv      = lift askRqEnv+    localRqEnv f  = DeprecatedError.mapErrorT (localRqEnv f)+    rqDataError e = lift (rqDataError e)+#endif++instance (Monad m, HasRqData m) => HasRqData (ExceptT e m) where+    askRqEnv      = lift askRqEnv+    localRqEnv f  = mapExceptT (localRqEnv f)+    rqDataError e = lift (rqDataError e)++-- | apply 'RqData a' to a 'RqEnv'+--+-- see also: 'getData', 'getDataFn', 'withData', 'withDataFn', 'RqData', 'getDataFn'+runRqData :: RqData a -> RqEnv -> Either [String] a+runRqData rqData rqEnv =+    either (Left . unErrors) Right $ runReaderError (unRqData rqData) rqEnv++-- | transform the result of 'RqData a'.+--+-- This is similar to 'fmap' except it also allows you to modify the+-- 'Errors' not just 'a'.+mapRqData :: (Either (Errors String) a -> Either (Errors String) b) -> RqData a -> RqData b+mapRqData f m = RqData $ ReaderError $ mapReaderT f (unReaderError (unRqData m))++-- | use 'read' to convert a 'String' to a value of type 'a'+--+-- > look "key" `checkRq` (unsafeReadRq "key")+--+-- use with 'checkRq'+--+-- NOTE: This function is marked unsafe because some Read instances+-- are vulnerable to attacks that attempt to create an out of memory+-- condition. For example:+--+-- > read "1e10000000000000" :: Integer+--+-- see also: 'readRq'+unsafeReadRq :: (Read a) =>+          String -- ^ name of key (only used for error reporting)+       -> String -- ^ 'String' to 'read'+       -> Either String a -- ^ 'Left' on error, 'Right' on success+unsafeReadRq key val =+    case reads val of+      [(a,[])] -> Right a+      _        -> Left $ "readRq failed while parsing key: " ++ key ++ " which has the value: " ++ val++-- | use 'fromReqURI' to convert a 'String' to a value of type 'a'+--+-- > look "key" `checkRq` (readRq "key")+--+-- use with 'checkRq'+readRq :: (FromReqURI a) =>+          String -- ^ name of key (only used for error reporting)+       -> String -- ^ 'String' to 'read'+       -> Either String a -- ^ 'Left' on error, 'Right' on success+readRq key val =+    case fromReqURI val of+      (Just a) -> Right a+      _        -> Left $ "readRq failed while parsing key: " ++ key ++ " which has the value: " ++ val++-- | convert or validate a value+--+-- This is similar to 'fmap' except that the function can fail by+-- returning Left and an error message. The error will be propagated+-- by calling 'rqDataError'.+--+-- This function is useful for a number of things including:+--+--  (1) Parsing a 'String' into another type+--+--  (2) Checking that a value meets some requirements (for example, that is an Int between 1 and 10).+--+-- Example usage at:+--+-- <http://happstack.com/docs/crashcourse/RqData.html#rqdatacheckrq>+checkRq :: (Monad m, HasRqData m) => m a -> (a -> Either String b) -> m b+checkRq rq f =+    do a <- rq+       case f a of+         (Left e)  -> rqDataError (strMsg e)+         (Right b) -> return b++-- | like 'checkRq' but the check function can be monadic+checkRqM :: (Monad m, HasRqData m) => m a -> (a -> m (Either String b)) -> m b+checkRqM rq f =+    do a  <- rq+       eb <- f a+       case eb of+         (Left e)  -> rqDataError (strMsg e)+         (Right b) -> return b++-- | Used by 'withData' and 'getData'. Make your preferred data+-- type an instance of 'FromData' to use those functions.+class FromData a where+    fromData :: RqData a+{-+instance (Eq a,Show a,Xml a,G.Data a) => FromData a where+    fromData = do mbA <- lookPairs >>= return . normalize . fromPairs+                  case mbA of+                    Just a -> return a+                    Nothing -> fail "FromData G.Data failure"+--    fromData = lookPairs >>= return . normalize . fromPairs+-}+instance (FromData a, FromData b) => FromData (a,b) where+    fromData = (,)   <$> fromData <*> fromData++instance (FromData a, FromData b, FromData c) => FromData (a,b,c) where+    fromData = (,,)  <$> fromData <*> fromData <*> fromData++instance (FromData a, FromData b, FromData c, FromData d) => FromData (a,b,c,d) where+    fromData = (,,,) <$> fromData <*> fromData <*> fromData <*> fromData++instance FromData a => FromData (Maybe a) where+    fromData = (Just <$> fromData) <|> (pure Nothing)++-- | similar to 'Data.List.lookup' but returns all matches not just the first+lookups :: (Eq a) => a -> [(a, b)] -> [b]+lookups a = map snd . filter ((a ==) . fst)++fromMaybeBody :: String -> String -> Maybe [(String, Input)] -> [(String, Input)]+fromMaybeBody funName fieldName mBody =+    case mBody of+      Nothing -> error $ funName ++ " " ++ fieldName ++ " failed because the request body has not been decoded yet. Try using 'decodeBody' to decode the body. Or the 'queryString' filter to ignore the body."+      (Just bdy) -> bdy++-- | Gets the first matching named input parameter+--+-- Searches the QUERY_STRING followed by the Request body.+--+-- see also: 'lookInputs'+lookInput :: (Monad m, HasRqData m) => String -> m Input+lookInput name+    = do (query, mBody, _cookies) <- askRqEnv+         let bdy = fromMaybeBody "lookInput" name mBody+         case lookup name (query ++ bdy) of+           Just i  -> return $ i+           Nothing -> rqDataError (strMsg $ "Parameter not found: " ++ name)++-- | Gets all matches for the named input parameter+--+-- Searches the QUERY_STRING followed by the Request body.+--+-- see also: 'lookInput'+lookInputs :: (Monad m, HasRqData m) => String -> m [Input]+lookInputs name+    = do (query, mBody, _cookies) <- askRqEnv+         let bdy = fromMaybeBody "lookInputs" name mBody+         return $ lookups name (query ++ bdy)++-- | Gets the first matching named input parameter as a lazy 'ByteString'+--+-- Searches the QUERY_STRING followed by the Request body.+--+-- see also: 'lookBSs'+lookBS :: (Functor m, Monad m, HasRqData m) => String -> m L.ByteString+lookBS n =+    do i <- fmap inputValue (lookInput n)+       case i of+         (Left _fp) -> rqDataError $ (strMsg $ "lookBS: " ++ n ++ " is a file.")+         (Right bs) -> return bs++-- | Gets all matches for the named input parameter as lazy 'ByteString's+--+-- Searches the QUERY_STRING followed by the Request body.+--+-- see also: 'lookBS'+lookBSs :: (Functor m, Monad m, HasRqData m) => String -> m [L.ByteString]+lookBSs n =+    do is <- fmap (map inputValue) (lookInputs n)+       case partitionEithers is of+         ([], bs) -> return bs+         (_fp, _) -> rqDataError (strMsg $ "lookBSs: " ++ n ++ " is a file.")++-- | Gets the first matching named input parameter as a 'String'+--+-- Searches the QUERY_STRING followed by the Request body.+--+-- This function assumes the underlying octets are UTF-8 encoded.+--+-- Example:+--+-- > handler :: ServerPart Response+-- > handler =+-- >      do foo <- look "foo"+-- >         ok $ toResponse $ "foo = " ++ foo+--+-- see also: 'looks', 'lookBS', and 'lookBSs'+look :: (Functor m, Monad m, HasRqData m) => String -> m String+look = fmap LU.toString . lookBS++-- | Gets all matches for the named input parameter as 'String's+--+-- Searches the QUERY_STRING followed by the Request body.+--+-- This function assumes the underlying octets are UTF-8 encoded.+--+-- see also: 'look' and 'lookBSs'+looks :: (Functor m, Monad m, HasRqData m) => String -> m [String]+looks = fmap (map LU.toString) . lookBSs++-- | Gets the first matching named input parameter as a lazy 'Text'+--+-- Searches the QUERY_STRING followed by the Request body.+--+-- This function assumes the underlying octets are UTF-8 encoded.+--+-- see also: 'lookTexts', 'look', 'looks', 'lookBS', and 'lookBSs'+lookText :: (Functor m, Monad m, HasRqData m) => String -> m LazyText.Text+lookText = fmap LazyText.decodeUtf8 . lookBS++-- | Gets the first matching named input parameter as a strict 'Text'+--+-- Searches the QUERY_STRING followed by the Request body.+--+-- This function assumes the underlying octets are UTF-8 encoded.+--+-- see also: 'lookTexts', 'look', 'looks', 'lookBS', and 'lookBSs'+lookText' :: (Functor m, Monad m, HasRqData m) => String -> m Text+lookText' = fmap LazyText.toStrict . lookText++-- | Gets all matches for the named input parameter as lazy 'Text's+--+-- Searches the QUERY_STRING followed by the Request body.+--+-- This function assumes the underlying octets are UTF-8 encoded.+--+-- see also: 'lookText', 'looks' and 'lookBSs'+lookTexts :: (Functor m, Monad m, HasRqData m) => String -> m [LazyText.Text]+lookTexts = fmap (map LazyText.decodeUtf8) . lookBSs++-- | Gets all matches for the named input parameter as strict 'Text's+--+-- Searches the QUERY_STRING followed by the Request body.+--+-- This function assumes the underlying octets are UTF-8 encoded.+--+-- see also: 'lookText'', 'looks' and 'lookBSs'+lookTexts' :: (Functor m, Monad m, HasRqData m) => String -> m [Text]+lookTexts' = fmap (map LazyText.toStrict) . lookTexts++-- | Gets the named cookie+-- the cookie name is case insensitive+lookCookie :: (Monad m, HasRqData m) => String -> m Cookie+lookCookie name+    = do (_query,_body, cookies) <- askRqEnv+         case lookup (map toLower name) cookies of -- keys are lowercased+           Nothing -> rqDataError $ strMsg $ "lookCookie: cookie not found: " ++ name+           Just c  -> return c{cookieValue = f c}+  where+    f = unEscapeString . cookieValue++-- | gets the named cookie as a string+lookCookieValue :: (Functor m, Monad m, HasRqData m) => String -> m String+lookCookieValue = fmap cookieValue . lookCookie++-- | gets the named cookie as the requested Read type+readCookieValue :: (Functor m, Monad m, HasRqData m, FromReqURI a) => String -> m a+readCookieValue name = fmap cookieValue (lookCookie name) `checkRq` (readRq name)++-- | Gets the first matching named input parameter and decodes it using 'Read'+--+-- Searches the QUERY_STRING followed by the Request body.+--+-- This function assumes the underlying octets are UTF-8 encoded.+--+-- see also: 'lookReads'+lookRead :: (Functor m, Monad m, HasRqData m, FromReqURI a) => String -> m a+lookRead name = look name `checkRq` (readRq name)++-- | Gets all matches for the named input parameter and decodes them using 'Read'+--+-- Searches the QUERY_STRING followed by the Request body.+--+-- This function assumes the underlying octets are UTF-8 encoded.+--+-- see also: 'lookReads'+lookReads :: (Functor m, Monad m, HasRqData m, FromReqURI a) => String -> m [a]+lookReads name =+    do vals <- looks name+       mapM (\v -> (return v) `checkRq` (readRq name)) vals++-- | Gets the first matching named file+--+-- Files can only appear in the request body. Additionally, the form+-- must set enctype=\"multipart\/form-data\".+--+-- This function returns a tuple consisting of:+--+--  (1) The temporary location of the uploaded file+--+--  (2) The local filename supplied by the browser+--+--  (3) The content-type supplied by the browser+--+-- If the user does not supply a file in the html form input field,+-- the behaviour will depend upon the browser. Most browsers will send+-- a 0-length file with an empty file name, so checking that (2) is+-- not empty is usually sufficient to ensure the field has been+-- filled.+--+-- NOTE: You must move the file from the temporary location before the+-- 'Response' is sent. The temporary files are automatically removed+-- after the 'Response' is sent.+lookFile :: (Monad m, HasRqData m) =>+            String -- ^ name of input field to search for+         -> m (FilePath, FilePath, ContentType) -- ^ (temporary file location, uploaded file name, content-type)+lookFile n =+    do i <- lookInput n+       case inputValue i of+         (Right _) -> rqDataError $ (strMsg $ "lookFile: " ++ n ++ " was found but is not a file.")+         (Left fp) -> return (fp, fromJust $ inputFilename i, inputContentType i)++-- | gets all the input parameters, and converts them to a 'String'+--+-- The results will contain the QUERY_STRING followed by the Request+-- body.+--+-- This function assumes the underlying octets are UTF-8 encoded.+--+-- see also: 'lookPairsBS'+lookPairs :: (Monad m, HasRqData m) => m [(String, Either FilePath String)]+lookPairs =+    do (query, mBody, _cookies) <- askRqEnv+       let bdy = fromMaybeBody "lookPairs" "" mBody+       return $ map (\(n,vbs)->(n, (\e -> case e of Left fp -> Left fp ; Right bs -> Right (LU.toString bs)) $ inputValue vbs)) (query ++ bdy)++-- | gets all the input parameters+--+-- The results will contain the QUERY_STRING followed by the Request+-- body.+--+-- see also: 'lookPairs'+lookPairsBS :: (Monad m, HasRqData m) => m [(String, Either FilePath L.ByteString)]+lookPairsBS =+    do (query, mBody, _cookies) <- askRqEnv+       let bdy = fromMaybeBody "lookPairsBS" "" mBody+       return $ map (\(n,vbs) -> (n, inputValue vbs)) (query ++ bdy)++-- | The body of a 'Request' is not received or decoded unless+-- this function is invoked.+--+-- It is an error to try to use the look functions for a+-- 'Request' with out first calling this function.+--+-- It is ok to call 'decodeBody' at the beginning of every request:+--+-- > main = simpleHTTP nullConf $+-- >           do decodeBody (defaultBodyPolicy "/tmp/" 4096 4096 4096)+-- >              handlers+--+-- You can achieve finer granularity quotas by calling 'decodeBody'+-- with different values in different handlers.+--+-- Only the first call to 'decodeBody' will have any effect. Calling+-- it a second time, even with different quota values, will do+-- nothing.+decodeBody :: (ServerMonad m, MonadPlus m, MonadIO m, FilterMonad Response m, WebMonad Response m) => BodyPolicy -> m ()+decodeBody bp =+    do rq <- askRq+       (_, me) <- bodyInput bp rq+       case me of+         Nothing -> return ()+         Just e  -> escape $ requestEntityTooLarge (toResponse e) -- FIXME: is this the best way to report the error++-- | run 'RqData' in a 'ServerMonad'.+--+-- Example: a simple @GET@ or @POST@ variable based authentication+-- guard.  It handles the request with 'errorHandler' if+-- authentication fails.+--+-- >  data AuthCredentials = AuthCredentials { username :: String,  password :: String }+-- >+-- >  isValid :: AuthCredentials -> Bool+-- >  isValid = const True+-- >+-- >  myRqData :: RqData AuthCredentials+-- >  myRqData = do+-- >     username <- look "username"+-- >     password <- look "password"+-- >     return (AuthCredentials username password)+-- >+-- >  checkAuth :: (String -> ServerPart Response) -> ServerPart Response+-- >  checkAuth errorHandler = do+-- >     d <- getDataFn myRqData+-- >     case d of+-- >         (Left e) -> errorHandler (unlines e)+-- >         (Right a) | isValid a -> mzero+-- >         (Right a) | otherwise -> errorHandler "invalid"+--+-- NOTE: you must call 'decodeBody' prior to calling this function if+-- the request method is POST, PUT, PATCH, etc.+getDataFn :: (HasRqData m, ServerMonad m) =>+             RqData a -- ^ 'RqData' monad to evaluate+          -> m (Either [String] a) -- ^ return 'Left' errors or 'Right' a+getDataFn rqData =+    do rqEnv <- askRqEnv+       return (runRqData rqData rqEnv)++-- | similar to 'getDataFn', except it calls a sub-handler on success+-- or 'mzero' on failure.+--+-- NOTE: you must call 'decodeBody' prior to calling this function if+-- the request method is POST, PUT, PATCH, etc.+withDataFn :: (HasRqData m, MonadPlus m, ServerMonad m) => RqData a -> (a -> m r) -> m r+withDataFn fn handle = getDataFn fn >>= either (const mzero) handle++-- | A variant of 'getDataFn' that uses 'FromData' to chose your+-- 'RqData' for you.  The example from 'getData' becomes:+--+-- >  data AuthCredentials = AuthCredentials { username :: String,  password :: String }+-- >+-- >  isValid :: AuthCredentials -> Bool+-- >  isValid = const True+-- >+-- >  myRqData :: RqData AuthCredentials+-- >  myRqData = do+-- >     username <- look "username"+-- >     password <- look "password"+-- >     return (AuthCredentials username password)+-- >+-- >  instance FromData AuthCredentials where+-- >     fromData = myRqData+-- >+-- >  checkAuth :: (String -> ServerPart Response) -> ServerPart Response+-- >  checkAuth errorHandler = do+-- >     d <- getData+-- >     case d of+-- >         (Left e) -> errorHandler (unlines e)+-- >         (Right a) | isValid a -> mzero+-- >         (Right a) | otherwise -> errorHandler "invalid"+--+-- NOTE: you must call 'decodeBody' prior to calling this function if+-- the request method is POST, PUT, PATCH, etc.+getData :: (HasRqData m, ServerMonad m, FromData a) => m (Either [String] a)+getData = getDataFn fromData++-- | similar to 'getData' except it calls a subhandler on success or 'mzero' on failure.+--+-- NOTE: you must call 'decodeBody' prior to calling this function if+-- the request method is POST, PUT, PATCH, etc.+withData :: (HasRqData m, FromData a, MonadPlus m, ServerMonad m) => (a -> m r) -> m r+withData = withDataFn fromData++-- | limit the scope to the Request body+--+-- > handler :: ServerPart Response+-- > handler =+-- >     do foo <- body $ look "foo"+-- >        ok $ toResponse $ "foo = " ++ foo+body :: (HasRqData m) => m a -> m a+body rqData = localRqEnv f rqData+    where+      f (_query, bdy, _cookies) = ([], bdy, [])++-- | limit the scope to the QUERY_STRING+--+-- > handler :: ServerPart Response+-- > handler =+-- >     do foo <- queryString $ look "foo"+-- >        ok $ toResponse $ "foo = " ++ foo+queryString ::  (HasRqData m) => m a -> m a+queryString rqData = localRqEnv f rqData+    where+      f (query, _body, _cookies) = (query, Just [], [])++-- | limit the scope to 'Input's  which produce a 'ByteString' (aka, not a file)+bytestring :: (HasRqData m) => m a -> m a+bytestring rqData = localRqEnv f rqData+    where+      f (query, bdy, cookies) = (filter bsf query, filter bsf <$> bdy, cookies)+      bsf (_, i) =+          case inputValue i of+            (Left  _fp) -> False+            (Right _bs) -> True
− src/Happstack/Server/S3.hs 
@@ -1,240 +0,0 @@-{-# LANGUAGE PatternGuards #-}-module Happstack.Server.S3-    ( newS3        -- :: AccessKey -> SecretKey -> URI -> IO S3-    , closeS3      -- :: S3 -> IO ()-    , createBucket -- :: S3 -> BucketId -> IO ()-    , createObject -- :: S3 -> BucketId -> ObjectId -> String -> IO ()-    , getObject    -- :: S3 -> BucketId -> ObjectId -> IO String-    , deleteBucket -- :: S3 -> BucketId -> IO ()-    , deleteObject -- :: S3 -> BucketId -> ObjectId -> IO ()-    , listObjects  -- :: S3 -> BucketId -> IO [String]-    , sendRequest  -- :: S3 -> Request -> IO String-    , sendRequest_ -- :: S3 -> Request -> IO ()---    , sendRequests -- :: S3 -> [Request] -> IO ()-    , BucketId, ObjectId, AccessKey, SecretKey-    , amazonURI-    ) where--import Happstack.Crypto.HMAC             ( hmacSHA1 )-import Happstack.Server.HTTPClient.HTTP-import qualified Happstack.Server.HTTPClient.Stream as Stream--import Network.URI hiding (path)-import Control.Concurrent               ( newMVar, modifyMVar, swapMVar-                                        , modifyMVar_, MVar )-import Data.Maybe                       ( fromJust, fromMaybe )-import Data.List                        ( intersperse )-import System.Time                      ( getClockTime, toCalendarTime-                                        , formatCalendarTime )-import System.Locale                    ( defaultTimeLocale, rfc822DateFormat )--import Text.XML.HaXml                   ( xmlParse, Document(..), Content(..) )-import Text.XML.HaXml.Xtract.Parse      ( xtract )--type BucketId = String-type ObjectId = String-type AccessKey = String-type SecretKey = String--data S3-    = S3-    { s3AccessKey        :: AccessKey-    , s3SecretKey        :: SecretKey-    , s3URI              :: URI---    , s3KeepAliveTimeout :: Int-    , s3Conn             :: MVar (Maybe Connection)-    }--{- |-  Sign a request using the access key and secret key from the S3 data-  type.--}-signRequest :: S3 -> Request -> IO Request-signRequest s3-    = let akey = s3AccessKey s3-          skey = s3SecretKey s3-      in signRequest' akey skey--{- |-  Fill in necessary information (such as a date header) and then sign-  then request.--}-signRequest' :: AccessKey -> SecretKey -> Request -> IO Request-signRequest' akey skey request-    = do now <- getClockTime-         cal <- toCalendarTime now-         let isoDate = formatCalendarTime defaultTimeLocale rfc822DateFormat cal-             auth = fromJust (uriAuthority (rqURI request))---             authErr = error "S3.hs: internal error: failed to parse authority"-         let dat = concat $ intersperse "\n"-                   [show (rqMethod request)-                   ,lookupHeader HdrContentMD5-                   ,lookupHeader HdrContentType-                   ,isoDate-                   ,uriPath (rqURI request)]-             authorization = Header HdrAuthorization $ "AWS " ++ akey ++ ":" ++ signature-             signature = hmacSHA1 skey dat-             lookupHeader hn = fromMaybe "" (findHeader hn request)-             dateHdr = Header HdrDate isoDate-             lengthHdr = Header HdrContentLength (show $ length (rqBody request))-             connHdr = Header HdrConnection "Keep-Alive"-             hostHdr = Header HdrHost (uriRegName auth)-         return $ request-                    { rqHeaders = hostHdr:connHdr:lengthHdr:dateHdr:-                                  authorization:rqHeaders request-                    , rqURI = (rqURI request) { uriScheme = ""-                                              , uriAuthority = Nothing}}--{- |-  Return a connection to an S3 server. Will initiate a new-  connection if no previous was found.--}-getConnection :: S3 -> IO Connection-getConnection s3-    = modifyMVar (s3Conn s3) $ \mbConn ->-      case mbConn of-        Just conn -> return (mbConn,conn)-        Nothing -> do print (uriRegName auth, uriPort auth)-                      c <- openTCPPort (uriRegName auth) (if null $ uriPort auth then 80 else read$ uriPort auth)-                      return (Just c,c)-    where auth = fromJust (uriAuthority (s3URI s3))--createRequest :: S3 -> RequestMethod -> String -> String -> Request-createRequest _s3 method path body-    = Request uri method [] body-    where uri = localhost { uriPath = '/':escapeURIString isAllowedInURI path }--{- |-  Send a single request to an S3 server returning the body-  of the result.--}-sendRequest :: S3 -> Request -> IO String-sendRequest s3 request-    = loop =<< signRequest s3 request-    where loop request'-              = do c <- getConnection s3-                   ret <- sendHTTP c request'-                   case ret of-                     Left ErrorClosed-                         -> do putStrLn "Connection closed."-                               swapMVar (s3Conn s3) Nothing-                               loop request'-                     Left err  -> error ("Failed to connect: " ++ show err) -- FIXME-                     Right res-                         | (2,_,_) <- rspCode res -> return (rspBody res)-                         | otherwise -> error ("Server error: " ++ rspReason res)--{- |-  Same as 'sendRequest' except that it ignored the result.--}-sendRequest_ :: S3 -> Request -> IO ()-sendRequest_ s3 request-    = do sendRequest s3 request-         return ()--{--  Sign and send requests pipelined over a keep-alive connection.--}-{--  S3 imposes a quite severe limitation on pipelined requests.-  Sending too many requests or exceeding a size limit will-  result in a disconnect. The precise borders of these limits-  are hard-wired and unknown to the general public. At the time-  of this writing, sending three requests at a time seems optimal.--  Quote from Amazons web-forum:-  (http://developer.amazonwebservices.com/connect/thread.jspa?messageID=39883)-  "OK, we have located the cause of the behavior you are seeing.-   Your pipelined requests are being aborted because one of the-   network devices handling the connection has certain limitations-   on the amount of pipelined data it is willing to accept per-   connection, and that limit is being exceeded. Unfortunately, this-   limit is phrased in very low-level terms so it isn't possible to-   say in a platform or network independent way whether any given-   size, sequence or number of requests will exceed the limit and-   cause a disconnection or not. We have engaged with the device-   vendor and found out that this limit is hard-wired and that this-   behavior is not likely to change any time soon.--   In light of these facts, here is some guidance on pipelining HTTP-   requests to Amazon S3.-    1) Be optimistic and pipeline a modest number of GET or HEAD-       requests, say two to four.-    2) Handle asynchronous disconnects by re-connecting and re-sending-       unacknowledged requests left in your pipeline. (As Colin points-       out, correct HTTP clients must do this anyway)-    3) If possible, try to minimize the number of TCP segments your-       pipelined requests generate. In particular, leave the TCP socket-       no delay option off and send as many requests per socket write call-       as is practical."--}------------------------------------------------------------------- Initiate-----------------------------------------------------------------newS3 :: AccessKey -> SecretKey -> URI -> IO S3-newS3 akey skey uri-    = do conn <- newMVar Nothing-         return $ S3 { s3AccessKey = akey-                     , s3SecretKey = skey-                     , s3URI       = uri---                     , s3KeepAliveTimeout :: Int-                     , s3Conn      = conn-                     }--closeS3 :: S3 -> IO ()-closeS3 s3-    = modifyMVar_ (s3Conn s3) $ \mbConn ->-      case mbConn of-        Nothing -> return Nothing-        Just conn -> do Stream.close conn-                        return Nothing-------------------------------------------------------------------- Requests------------------------------------------------------------------createBucket :: S3 -> BucketId -> Request-createBucket s3 bucket-    = createRequest s3 PUT bucket ""--createObject :: S3 -> BucketId -> ObjectId -> String -> Request-createObject s3 bucket object-    = createRequest s3 PUT (bucket ++ "/" ++ object)--getObject :: S3 -> BucketId -> ObjectId -> Request-getObject s3 bucket object-    = createRequest s3 GET (bucket ++ "/" ++ object) ""--deleteBucket :: S3 -> BucketId -> Request-deleteBucket s3 bucket-    = createRequest s3 DELETE bucket ""--deleteObject :: S3 -> BucketId -> ObjectId -> Request-deleteObject s3 bucket object-    = createRequest s3 DELETE (bucket ++ "/" ++ object) ""------------------------------------------------------------------- Actions------------------------------------------------------------------listObjects :: S3 -> BucketId -> IO [String]-listObjects s3 bucket-    = do lst <- sendRequest s3 (createRequest s3 GET bucket "")-         return $ ppContent . auxFilter . getContent . xmlParse bucket $ lst-    where auxFilter = xtract "*/Key/-"-          getContent (Document _ _ e _) = CElem e--          ppContent xs  = [ s | CString _ s <- xs ]----amazonURI :: URI-amazonURI = fromJust $ parseURI "http://s3.amazonaws.com/"-localhost :: URI-localhost = fromJust $ parseURI "http://localhost/"-
src/Happstack/Server/SURI.hs view
@@ -1,10 +1,32 @@-{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances #-}+-- | A wrapper and type class so that functions like 'seeOther' can take a URI which is represented by a 'String', 'URI.URI', or other instance of 'ToSURI'.+module Happstack.Server.SURI+    ( path+    , query+    , scheme+    , u_scheme+    , u_path+    , a_scheme+    , a_path+    , percentDecode+    , unEscape+    , unEscapeQS+    , isAbs+    , SURI(..)+    , render+    , parse+    , ToSURI(..)+    , FromPath(..)+    )+    where -module Happstack.Server.SURI where-import Data.Maybe-import Data.Generics-import Happstack.Util.Common(mapFst)-import qualified Network.URI as URI+import Control.Arrow (first)+import Data.Char     (chr, digitToInt, isHexDigit)+import Data.Maybe    (fromJust, isJust)+import Data.Generics (Data)+import qualified Data.Text      as Text+import qualified Data.Text.Lazy as LazyText+import qualified Network.URI    as URI  -- | Retrieves the path component from the URI path :: SURI -> String@@ -34,19 +56,32 @@ a_path :: String -> SURI -> SURI a_path a (SURI u) = SURI $ u {URI.uriPath=a} -escape, unEscape :: String -> String-unEscape = URI.unEscapeString . map (\x->if x=='+' then ' ' else x)-escape = URI.escapeURIString URI.isAllowedInURI+-- | percent decode a String+--+-- e.g. @\"hello%2Fworld\"@ -> @\"hello/world\"@+percentDecode :: String -> String+percentDecode [] = ""+percentDecode ('%':x1:x2:s) | isHexDigit x1 && isHexDigit x2 =+    chr (digitToInt x1 * 16 + digitToInt x2) : percentDecode s+percentDecode (c:s) = c : percentDecode s +unEscape, unEscapeQS :: String -> String+unEscapeQS = percentDecode . map (\x->if x=='+' then ' ' else x)+unEscape   = percentDecode+-- escape     = URI.escapeURIString URI.isAllowedInURI++-- | Returns true if the URI is absolute isAbs :: SURI -> Bool isAbs = not . null . URI.uriScheme . suri---isAbs = maybe True ( mbParsed -newtype SURI = SURI {suri::URI.URI} deriving (Eq,Data,Typeable)+newtype SURI = SURI {suri::URI.URI} deriving (Eq,Data) instance Show SURI where     showsPrec d (SURI uri) = showsPrec d $ show uri instance Read SURI where-    readsPrec d = mapFst fromJust .  filter (isJust . fst) . mapFst parse . readsPrec d +    readsPrec d = mapFst fromJust .  filter (isJust . fst) . mapFst parse . readsPrec d+      where+        mapFst :: (a -> b) -> [(a,x)] -> [(b,x)]+        mapFst = map . first  instance Ord SURI where     compare a b = show a `compare` show b@@ -57,16 +92,17 @@  -- | Parses a URI from a String.  Returns Nothing on failure. parse :: String -> Maybe SURI-parse =  fmap SURI . URI.parseURIReference +parse =  fmap SURI . URI.parseURIReference  -- | Convenience class for converting data types to URIs class ToSURI x where toSURI::x->SURI  instance ToSURI SURI where toSURI=id instance ToSURI URI.URI where toSURI=SURI-instance ToSURI String where +instance ToSURI String where     toSURI = maybe (SURI $ URI.URI "" Nothing "" "" "") id . parse-+instance ToSURI Text.Text where toSURI = toSURI . Text.unpack+instance ToSURI LazyText.Text where toSURI = toSURI . LazyText.unpack  --handling obtaining things from URI paths class FromPath x where fromPath::String->x
src/Happstack/Server/SURI/ParseURI.hs view
@@ -1,12 +1,13 @@ module Happstack.Server.SURI.ParseURI(parseURIRef) where +import qualified Data.ByteString          as BB import qualified Data.ByteString.Internal as BB import qualified Data.ByteString.Unsafe   as BB import Data.ByteString.Char8 as BC import Prelude hiding(break,length,null,drop,splitAt) import Network.URI -import Happstack.Util.ByteStringCompat+-- import Happstack.Util.ByteStringCompat  parseURIRef :: ByteString -> URI parseURIRef fs =@@ -79,3 +80,22 @@ unsafeIndex :: ByteString -> Int -> Char unsafeIndex s = BB.w2c . BB.unsafeIndex s +-- | Semantically equivalent to break on strings+{-# INLINE breakChar #-}+breakChar :: Char -> ByteString -> (ByteString, ByteString)+breakChar ch = BB.break ((==) x) where x = BB.c2w ch++-- | 'breakCharEnd' behaves like breakChar, but from the end of the+-- ByteString.+--+-- > breakCharEnd ('b') (pack "aabbcc") == ("aab","cc")+--+-- and the following are equivalent:+--+-- > breakCharEnd 'c' "abcdef"+-- > let (x,y) = break (=='c') (reverse "abcdef")+-- > in (reverse (drop 1 y), reverse x)+--+{-# INLINE breakCharEnd #-}+breakCharEnd :: Char -> ByteString -> (ByteString, ByteString)+breakCharEnd c p = BB.breakEnd ((==) x) p where x = BB.c2w c
src/Happstack/Server/SimpleHTTP.hs view
@@ -1,1355 +1,235 @@-{-# LANGUAGE UndecidableInstances, OverlappingInstances, ScopedTypeVariables, FlexibleInstances, TypeSynonymInstances,-    MultiParamTypeClasses, PatternGuards, FlexibleContexts, FunctionalDependencies, GeneralizedNewtypeDeriving, PatternSignatures-    #-}-{-# OPTIONS -fno-warn-orphans #-}--------------------------------------------------------------------------------- |--- Module      :  Happstack.Server.SimpleHTTP--- Copyright   :  (c) Happstack.com 2009; (c) HAppS Inc 2007--- License     :  BSD-like------ Maintainer  :  lemmih@vo.com--- Stability   :  provisional--- Portability :  requires mtl------ SimpleHTTP provides a back-end independent API for handling HTTP requests.------ By default, the built-in HTTP server will be used. However, other back-ends--- like CGI\/FastCGI can used if so desired.--- --- So the general nature of 'simpleHTTP' is no different than what you'd expect--- from a web application container.  First you figure out when function is--- going to process your request, process the request to generate a response,--- then return that response to the client. The web application container is--- started with 'simpleHTTP', which takes a configuration and a--- response-building structure ('ServerPartT' which I'll return too in a--- moment), and picks the first handler that is willing to accept the request,--- passes the request into the handler.  A simple "hello world" style HAppS--- simpleHTTP server looks like:------ @---   main = simpleHTTP nullConf $ return \"Hello World!\"--- @------ @simpleHTTP nullConf@ creates a HTTP server on port 8000.--- return \"Hello World!\" creates a serverPartT that just returns that text.------ 'ServerPartT' is the basic response builder.  As you might expect, it's a--- container for a function that takes a Request and converts it a response--- suitable for sending back to the server.  Most of the time though you don't--- even need to worry about that as ServerPartT hides almost all the machinery--- for building your response by exposing a few type classes.--- --- 'ServerPartT' is a pretty rich monad.  You can interact with your request,--- your response, do IO, etc.  Here is a do block that validates basic--- authentication It takes a realm name as a string, a Map of username to--- password and a server part to run if authentication fails.--- --- @basicAuth'@ acts like a guard, and only produces a response when--- authentication fails.  So put it before any ServerPartT you want to demand--- authentication for in any collection of ServerPartTs.------ @------ main = simpleHTTP nullConf $ myAuth, return \"Hello World!\"---     where---         myAuth = basicAuth\' \"Test\"---             (M.fromList [(\"hello\", \"world\")]) (return \"Login Failed\")------ basicAuth\' realmName authMap unauthorizedPart =---    do---        let validLogin name pass = M.lookup name authMap == Just pass---        let parseHeader = break (\':\'==) . Base64.decode . B.unpack . B.drop 6---        authHeader <- getHeaderM \"authorization\"---        case authHeader of---            Nothing -> err---            Just x  -> case parseHeader x of ---                (name, \':\':pass) | validLogin name pass -> mzero---                                   | otherwise -> err---                _                                       -> err---    where---        err = do---            unauthorized ()---            setHeaderM headerName headerValue---            unauthorizedPart---        headerValue = \"Basic realm=\\\"\" ++ realmName ++ \"\\\"\"---        headerName  = \"WWW-Authenticate\"--- @------ Here is another example that uses liftIO to embed IO in a request process------ @---   main = simpleHTTP nullConf $ myPart---   myPart = do---     line <- liftIO $ do -- IO---         putStr \"return? \"---         getLine---     when (take 2 line \/= \"ok\") $ (notfound () >> return \"refused\")---     return \"Hello World!\"--- @--- --- This example will ask in the console \"return? \" if you type \"ok\" it will--- show \"Hello World!\" and if you type anything else it will return a 404.----------------------------------------------------------------------------------module Happstack.Server.SimpleHTTP-    ( module Happstack.Server.HTTP.Types-    , module Happstack.Server.Cookie-    -- * SimpleHTTP-    , simpleHTTP-    , simpleHTTP'-    , parseConfig-    -- * ServerPartT-    , ServerPartT(..)-    , ServerPart-    , runServerPartT-    , mapServerPartT-    , mapServerPartT'-    , withRequest-    , anyRequest-    -- * WebT-    , WebT(..)-    , FilterFun-    , Web-    , mkWebT-    , ununWebT-    , runWebT-    , mapWebT-    -- * Type Classes-    , FromReqURI(..)-    , ToMessage(..)--      -- * Manipulating requests-    , FromData(..)-    , ServerMonad(..)-    , RqData-    , noHandle-    , getHeaderM-    , escape-    , escape'-    , multi-      -- * Manipulating responses-    , FilterMonad(..)-    , ignoreFilters-    , SetAppend(..)-    , FilterT(..)-    , WebMonad(..)-    , ok-    , modifyResponse-    , setResponseCode-    , badGateway-    , internalServerError-    , badRequest-    , unauthorized -    , forbidden-    , notFound-    , seeOther-    , found-    , movedPermanently-    , tempRedirect-    , addCookie-    , addCookies-    , addHeaderM-    , setHeaderM--     -- * guards and building blocks-    , guardRq-    , dir-    , method-    , methodSP-    , methodM-    , methodOnly-    , nullDir-    , path-    , anyPath-    , anyPath'-    , withData-    , withDataFn-    , getDataFn-    , getData-    , require-    , requireM-    , basicAuth-    , uriRest-    , flatten-    , localContext-      -- * proxying-    , proxyServe-    , rproxyServe-      -- * unknown-    , debugFilter-    , applyRequest-      -- * Parsing input and cookies-    , lookInput   -- :: String -> Data Input-    , lookBS      -- :: String -> Data B.ByteString-    , look        -- :: String -> Data String-    , lookCookie  -- :: String -> Data Cookie-    , lookCookieValue -- :: String -> Data String-    , readCookieValue -- :: Read a => String -> Data a-    , lookRead    -- :: Read a => String -> Data a-    , lookPairs-      -- * XSLT-    , xslt ,doXslt-      -- * Error Handlng-    , errorHandlerSP-    , simpleErrorHandler-    , spUnwrapErrorT-      -- * Output Validation-    , setValidator-    , setValidatorSP-    , validateConf-    , runValidator-    , wdgHTMLValidator-    , noopValidator-    , lazyProcValidator-    ) where-import qualified Paths_happstack_server as Cabal-import qualified Data.Version as DV-import Happstack.Server.HTTP.Client-import Happstack.Data.Xml.HaXml-import qualified Happstack.Server.MinHaXML as H--import Happstack.Server.HTTP.Types hiding (Version(..))-import qualified Happstack.Server.HTTP.Types as Types-import Happstack.Server.HTTP.Listen as Listen-import Happstack.Server.XSLT-import Happstack.Server.SURI (ToSURI)-import Happstack.Util.Common-import Happstack.Server.Cookie-import Happstack.Data -- used by default implementation of fromData-import Control.Applicative-import Control.Concurrent (forkIO)-import Control.Exception (evaluate)-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Error-import Control.Monad.Trans()-import Control.Monad.Maybe-import Control.Monad.Writer as Writer-import Data.Maybe-import Data.Monoid-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.Generics as G-import qualified Data.Map as M-import Text.Html (Html,renderHtml)-import qualified Text.XHtml as XHtml (Html,renderHtml)-import qualified Happstack.Crypto.Base64 as Base64-import Data.Char-import Data.List-import System.IO-import System.Console.GetOpt-import System.Process (runInteractiveProcess, waitForProcess)-import System.Exit-import Text.Show.Functions ()---- | An alias for WebT when using IO-type Web a = WebT IO a--- | An alias for using ServerPartT when using the IO-type ServerPart a = ServerPartT IO a------------------------------------------- HERE BEGINS ServerPartT definitions---- | ServerPartT is a container for processing requests and returning results-newtype ServerPartT m a = ServerPartT { unServerPartT :: ReaderT Request (WebT m) a }-    deriving (Monad, MonadIO, MonadPlus, Functor)---- | particularly useful when combined with runWebT to produce--- a @m (Maybe Response)@ from a request.-runServerPartT :: ServerPartT m a -> Request -> WebT m a-runServerPartT = runReaderT . unServerPartT--withRequest :: (Request -> WebT m a) -> ServerPartT m a-withRequest = ServerPartT . ReaderT---- | Used to manipulate the containing monad.  Very useful when embedding a--- monad into a ServerPartT, since simpleHTTP requires a @ServerPartT IO a@.--- Refer to 'WebT' for an explanation of the structure of the monad.------ Here is an example.  Suppose you want to embed an ErrorT into your--- ServerPartT to enable throwError and catchError in your Monad.------ @---   type MyServerPartT e m a = ServerPartT (ErrorT e m) a--- @------ Now suppose you want to pass MyServerPartT into a function--- that demands a @ServerPartT IO a@ (e.g. simpleHTTP).  You--- can provide the function:------ @---   unpackErrorT:: (Monad m, Show e) =>---       -> (ErrorT e m) (Maybe ((Either Response a), FilterFun Response))---       -> m (Maybe ((Either Response a), FilterFun Response))---   unpackErrorT handler et = do---      eitherV <- runErrorT et---      case eitherV of---          Left err -> return $ Just (Left "Catastrophic failure " ++ show e, Set $ Endo \r -> r{rsCode = 500})---          Right x -> return x--- @--- --- With @unpackErrorT@ you can now call simpleHTTP.  Just wrap your @ServerPartT@ list.------ @---   simpleHTTP nullConf $ mapServerPartT unpackErrorT (myPart \`catchError\` myHandler)--- @--- --- Or alternatively:------ @---   simpleHTTP' unpackErrorT nullConf (myPart \`catchError\` myHandler)--- @--- --- Also see 'spUnwrapErrorT' for a more sophisticated version of this function----mapServerPartT :: (m (Maybe (Either Response a, FilterFun Response)) -> n (Maybe (Either Response b, FilterFun Response))) -> ServerPartT m a -> ServerPartT n b-mapServerPartT f ma = withRequest $ \rq -> mapWebT f (runServerPartT ma rq)---- | A varient of mapServerPartT where the first argument, also takes a request.--- useful if you want to runServerPartT on a different ServerPartT inside your--- monad (see spUnwrapErrorT)-mapServerPartT' :: (Request -> m (Maybe (Either Response a, FilterFun Response)) -> n (Maybe (Either Response b, FilterFun Response))) -> ServerPartT m a -> ServerPartT n b-mapServerPartT' f ma = withRequest $ \rq -> mapWebT (f rq) (runServerPartT ma rq)-instance MonadTrans (ServerPartT) where-    lift m = withRequest (\_ -> lift m)--instance (Monad m) => Monoid (ServerPartT m a)- where mempty = mzero-       mappend = mplus--instance (Monad m, Functor m) => Applicative (ServerPartT m) where-    pure = return-    (<*>) = ap--instance (Monad m, MonadWriter w m) => MonadWriter w (ServerPartT m) where-    tell = lift . tell-    listen m = withRequest $ \rq ->  Writer.listen (runServerPartT m rq) >>= return-    pass m = withRequest $ \rq -> pass (runServerPartT m rq) >>= return--instance (Monad m, MonadError e m) => MonadError e (ServerPartT m) where-    throwError e = lift $ throwError e-    catchError action handler = withRequest $ \rq -> (runServerPartT action rq) `catchError` ((flip runServerPartT $ rq) . handler)--instance (Monad m, MonadReader r m) => MonadReader r (ServerPartT m) where-    ask = lift ask-    local fn m = withRequest $ \rq-> local fn (runServerPartT m rq)--instance Monad m => FilterMonad Response (ServerPartT m) where-    setFilter = anyRequest . setFilter-    composeFilter = anyRequest . composeFilter-    getFilter m = withRequest $ \rq -> getFilter (runServerPartT m rq)--instance Monad m => WebMonad Response (ServerPartT m) where-    finishWith r = anyRequest $ finishWith r---- | yes, this is exactly like 'ReaderT' with new names.--- Why you ask? Because ServerT can lift up a ReaderT.--- If you did that, it would shadow ServerT's behavior--- as a ReaderT, thus meaning if you lifted the ReaderT--- you could no longer modify the Request.  This way--- you can add a ReaderT to your monad stack without--- any trouble.-class Monad m => ServerMonad m where-    askRq :: m Request-    localRq :: (Request->Request)->m a->m a--instance (Monad m) => ServerMonad (ServerPartT m) where-    askRq = ServerPartT $ ask-    localRq f m = ServerPartT $ local f (unServerPartT m)----------------------------------- HERE BEGINS WebT definitions---- | A monoid operation container.--- If a is a monoid, then SetAppend is a monoid with the following behaviors:--- --- @---   Set x `mappend` Append y = Set (x `mappend` y)---   Append x `mappend` Append y = Append (x `mappend` y)---   \_     `mappend` Set y = Set y--- @------ A simple way of sumerizing this is, if the left side is Append, then the--- right is appended to the left.  If the left side is Set, then the right side--- is ignored.-data SetAppend a = Set a | Append a-    deriving (Eq, Show)-instance Monoid a => Monoid (SetAppend a) where-   mempty = Append mempty-   Set x    `mappend` Append y = Set (x `mappend` y)-   Append x `mappend` Append y = Append (x `mappend` y)-   _        `mappend` Set y    = Set y--value :: SetAppend t -> t-value (Set x) = x-value (Append x) = x--instance Functor (SetAppend) where-    fmap f (Set x) = Set $ f x-    fmap f (Append x) = Append $ f x---- | @FilterFun@ is a lot more fun to type than @SetAppend (Dual (Endo a))@-type FilterFun a = SetAppend (Dual (Endo a))--newtype FilterT a m b =-   FilterT { unFilterT :: WriterT (FilterFun a) m b }-   deriving (Monad, MonadTrans, Functor, MonadIO)---- | A set of functions for manipulating filters.  A ServerPartT implements--- FilterMonad Response so these methods are the fundamental ways of--- manipulating the response object, especially before you've converted your--- monadic value to a 'Response'-class Monad m => FilterMonad a m | m->a where-    -- | Ignores all previous-    -- alterations to your filter-    ---    -- As an example:-    ---    -- @-    --   do-    --     composeFilter f-    --     setFilter g-    --     return \"Hello World\"-    -- @-    ---    -- setFilter g will cause the first composeFilter to be-    -- ignored.-    setFilter :: (a->a) -> m ()-    -- |-    -- composes your filter function with the-    -- existing filter function.-    composeFilter :: (a->a) -> m ()-    -- | retrives the filter from the environment-    getFilter :: m b -> m (b,a->a)--instance (Monad m) => FilterMonad a (FilterT a m) where-    setFilter f = FilterT $ Writer.tell $ Set $ Dual $ Endo f-    composeFilter f = FilterT $ Writer.tell $ Append $ Dual $ Endo f-    getFilter m = FilterT $ Writer.listens (appEndo . getDual . value)  (unFilterT m) ---- | The basic response building object.---  It is worth discussing the unpacked structure of WebT a bit as it's exposed---  in 'mapServerPartT' and 'mapWebT'.------  A fully unpacked WebT has a structure that looks like:---  ---  @---    ununWebT $ WebT m a :: m (Maybe (Either Response a, FilterFun Response))---  @---   ---  So, ignoring m, as it is just the containing Monad, the outermost layer is---  a Maybe.  This is 'Nothing' if 'mzero' was called or @Just (Either Response---  a, SetAppend (Endo Response))@ if 'mzero' wasn't called.  Inside the Maybe,---  there is a pair.  The second element of the pair is our filter function---  @FilterFun Response@.  @FilterFun Response@ is a type alias for @SetAppend---  (Dual (Endo Response))@.  This is just a wrapper for a @Response->Response@---  function with a particular Monoid behavior.  The value------  @---      Append (Dual (Endo f))---  @------  Causes f to be composed with the previous filter.------  @---      Set (Dual (Endo f))---  @------  Causes f to not be composed with the previous filter.------  Finally, the first element of the pair is either @Left Response@ or @Right a@.------  Another way of looking at all these pieces is from the behaviors they control.  The Maybe---  controls the mzero behavior.  @Set (Endo f)@ comes from the setFilter behavior.---  Likewise, @Append (Endo f)@ is from composeFilter.  @Left Response@ is what you---  get when you call "finishWith" and @Right a@ is the normal exit.------  An example case statement looks like:---  @---    ex1 webt = do---      val <- ununWebT webt---      case val of---          Nothing -> Nothing  -- this is the interior value when mzero was used---          Just (Left r, f) -> Just (Left r, f) -- r is the value that was passed into "finishWith"---                                               -- f is our filter function---          Just (Right a, f) -> Just (Right a, f) -- a is our normal monadic value---                                                 -- f is still our filter function---  @---  -newtype WebT m a = WebT { unWebT :: ErrorT Response (FilterT (Response) (MaybeT m)) a }-    deriving (MonadIO, Functor)--instance Monad m => Monad (WebT m) where-    m >>= f = WebT $ unWebT m >>= unWebT . f-    return a = WebT $ return a-    fail s = mkFailMessage s--instance Error Response where-    strMsg = toResponse--class Monad m => WebMonad a m | m->a where-    -- | A control structure-    -- It ends the computation and returns the Response you passed into it-    -- immediately.  This provides an alternate escape route.  In particular-    -- it has a monadic value of any type.  And unless you call @'setFilter' id@-    -- first your response filters will be applied normally.-    ---    -- Extremely useful when you're deep inside a monad and decide that you-    -- want to return a completely different content type, since it doesn't-    -- force you to convert all your return types to Response early just to-    -- accomodate this.-    finishWith :: a -> m b--instance (Monad m) => WebMonad Response (WebT m) where-    finishWith r = WebT $ throwError r--instance MonadTrans WebT where-    lift = WebT . lift . lift . lift--instance (Monad m) => MonadPlus (WebT m) where-    -- | Aborts a computation.-    ---    -- This is primarily useful because msum will take an array-    -- of MonadPlus and return the first one that isn't mzero,-    -- which is exactly the semantics expected from objects-    -- that take lists of ServerPartT-    mzero = WebT $ lift $ lift $ mzero-    mplus x y =  WebT $ ErrorT $ FilterT $ (lower x) `mplus` (lower y)-        where lower = (unFilterT . runErrorT . unWebT)---- | deprecated.  use mzero-noHandle :: (MonadPlus m) => m a-noHandle = mzero-{-# DEPRECATED noHandle "Use mzero" #-}--instance (Monad m) => FilterMonad Response (WebT m) where-    setFilter f = WebT $ lift $ setFilter $ f-    composeFilter f = WebT . lift . composeFilter $ f-    getFilter m = WebT $ ErrorT $ getFilter (runErrorT $ unWebT m) >>= liftWebT-        where liftWebT (Left r, _) = return $ Left r-              liftWebT (Right a, f) = return $ Right (a, f)--instance (Monad m) => Monoid (WebT m a) where-    mempty = mzero-    mappend = mplus---- | takes your WebT, converts the monadic value to a Response,--- applys your filter, and returns it wrapped in a Maybe.-runWebT :: (ToMessage b, Monad m) => WebT m b -> m (Maybe Response)-runWebT m = runMaybeT $ do-                (r,ed) <- runWriterT $ unFilterT $ runErrorT $ unWebT $ m-                let f = appEndo $ getDual $ value ed-                return $ either (f) (f . toResponse) r--- | for when you really need to unpack a WebT entirely (and not--- just unwrap the first layer with unWebT)-ununWebT :: WebT m a-    -> m (Maybe-            (Either Response a,-             FilterFun Response))-ununWebT = runMaybeT . runWriterT . unFilterT . runErrorT . unWebT---- | for wrapping a WebT back up.  @mkWebT . ununWebT = id@-mkWebT :: m (Maybe-       (Either Response a,-        FilterFun Response)) -> WebT m a-mkWebT = WebT . ErrorT . FilterT . WriterT . MaybeT---- | see 'mapServerPartT' for a discussion of this function-mapWebT :: (m (Maybe (Either Response a, FilterFun Response)) -> n (Maybe (Either Response b, FilterFun Response))) -> WebT m a -> WebT n b-mapWebT f ma = mkWebT $  f (ununWebT ma)---instance (Monad m, Functor m) => Applicative (WebT m) where-    pure = return-    (<*>) = ap--instance MonadReader r m => MonadReader r (WebT m) where-    ask = lift ask-    local fn m = mkWebT $ local fn (ununWebT m)--instance MonadState st m => MonadState st (WebT m) where-    get = lift get-    put = lift . put--instance MonadError e m => MonadError e (WebT m) where-	throwError err = lift $ throwError err- 	catchError action handler = mkWebT $ catchError (ununWebT action) (ununWebT . handler)--instance MonadWriter w m => MonadWriter w (WebT m) where-    tell = lift . Writer.tell-    listen m = mkWebT $ Writer.listen (ununWebT m) >>= (return . liftWebT)-        where liftWebT (Nothing, _) = Nothing-              liftWebT (Just (Left x,f), _) = Just (Left x,f)-              liftWebT (Just (Right x,f),w) = Just (Right (x,w),f)-    pass m = mkWebT $ ununWebT m >>= liftWebT-        where liftWebT Nothing = return Nothing-              liftWebT (Just (Left x,f)) = return $ Just (Left x, f)-              liftWebT (Just (Right x,f)) = pass (return x)>>= (\a -> return $ Just (Right a,f))---- | An alias for setFilter id--- It resets all your filters-ignoreFilters :: (FilterMonad a m) => m ()-ignoreFilters = setFilter id---- | Used to ignore all your filters--- and immediately end the computation.  A combination of--- 'ignoreFilters' and 'finishWith'-escape :: (WebMonad a m, FilterMonad a m) => m a -> m b-escape gen = ignoreFilters >> gen >>= finishWith---- | An alternate form of 'escape' that can--- be easily used within a do block.-escape' :: (WebMonad a m, FilterMonad a m) => a -> m b-escape' a = ignoreFilters >> finishWith a--------------------------------------------------- additional types----- | An array of 'OptDescr', useful for processing--- command line options into an 'Conf' for 'simpleHTTP'-ho :: [OptDescr (Conf -> Conf)]-ho = [Option [] ["http-port"] (ReqArg (\h c -> c { port = read h }) "port") "port to bind http server"]---- | parseConfig tries to parse your command line options--- into a Conf.-parseConfig :: [String] -> Either [String] Conf-parseConfig args-    = case getOpt Permute ho args of-        (flags,_,[]) -> Right $ foldr ($) nullConf flags-        (_,_,errs)   -> Left errs---- | Use the built-in web-server to serve requests according to a 'ServerPartT'.--- Use msum to pick the first handler from a list of handlers that doesn't call--- noHandle.-simpleHTTP :: (ToMessage a) => Conf -> ServerPartT IO a -> IO ()-simpleHTTP = simpleHTTP' id---- | a combination of simpleHTTP and 'mapServerPartT'.  See 'mapServerPartT' for a discussion--- of the first argument of this function.-simpleHTTP' :: (Monad m, ToMessage b) =>-   (m (Maybe (Either Response a, FilterFun Response))-   -> IO (Maybe (Either Response b, FilterFun Response)))-   -> Conf-   -> ServerPartT m a-   -> IO ()-simpleHTTP' toIO conf hs = do-    Listen.listen conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req))-    ---- | Generate a result from a 'ServerPart' and a 'Request'. This is mainly used--- by CGI (and fast-cgi) wrappers.-simpleHTTP'' :: (ToMessage b, Monad m) => ServerPartT m b -> Request -> m Response-simpleHTTP'' hs req =  (runWebT $ runServerPartT hs req) >>= (return . (maybe standardNotFound id))-    where-        standardNotFound = setHeader "Content-Type" "text/html" $ toResponse notFoundHtml----- | a wrapper for Read apparently.  Pretty much only used for 'path' and probably--- unnecessarily, as it is exactly "readM"-class FromReqURI a where-    fromReqURI :: String -> Maybe a----instance FromReqURI String where fromReqURI = Just-instance FromReqURI Int where    fromReqURI = readM-instance FromReqURI Integer where    fromReqURI = readM-instance FromReqURI Float where  fromReqURI = readM-instance FromReqURI Double where fromReqURI = readM--type RqData a = ReaderT ([(String,Input)], [(String,Cookie)]) Maybe a---- | Useful for withData and getData'  implement this on your preferred type--- to use those functions-class FromData a where-    fromData :: RqData a--instance (Eq a,Show a,Xml a,G.Data a) => FromData a where-    fromData = do mbA <- lookPairs >>= return . normalize . fromPairs-                  case mbA of-                    Just a -> return a-                    Nothing -> fail "FromData G.Data failure"---    fromData = lookPairs >>= return . normalize . fromPairs--instance (FromData a, FromData b) => FromData (a,b) where-    fromData = liftM2 (,) fromData fromData-instance (FromData a, FromData b, FromData c) => FromData (a,b,c) where-    fromData = liftM3 (,,) fromData fromData fromData-instance (FromData a, FromData b, FromData c, FromData d) => FromData (a,b,c,d) where-    fromData = liftM4 (,,,) fromData fromData fromData fromData-instance FromData a => FromData (Maybe a) where-    fromData = fmap Just fromData `mplus` return Nothing---- |---  Minimal definition: 'toMessage'------  Used to convert arbitrary types into an HTTP response.  You need to implement---  this if you want to pass @ServerPartT m@ containing your type into simpleHTTP-class ToMessage a where-    toContentType :: a -> B.ByteString-    toContentType _ = B.pack "text/plain"-    toMessage :: a -> L.ByteString-    toMessage = error "Happstack.Server.SimpleHTTP.ToMessage.toMessage: Not defined"-    toResponse:: a -> Response-    toResponse val =-        let bs = toMessage val-            res = Response 200 M.empty nullRsFlags bs Nothing-        in setHeaderBS (B.pack "Content-Type") (toContentType val)-           res--instance ToMessage [Element] where-    toContentType _ = B.pack "application/xml"-    toMessage [el] = L.pack $ H.simpleDoc H.NoStyle $ toHaXmlEl el -- !! OPTIMIZE-    toMessage x    = error ("Happstack.Server.SimpleHTTP 'instance ToMessage [Element]' Can't handle " ++ show x)-----instance ToMessage () where-    toContentType _ = B.pack "text/plain"-    toMessage () = L.empty-instance ToMessage String where-    toContentType _ = B.pack "text/plain"-    toMessage = L.pack-instance ToMessage Integer where-    toMessage = toMessage . show-instance ToMessage a => ToMessage (Maybe a) where-    toContentType _ = toContentType (undefined :: a)-    toMessage Nothing = toMessage "nothing"-    toMessage (Just x) = toMessage x---instance ToMessage Html where-    toContentType _ = B.pack "text/html"-    toMessage = L.pack . renderHtml--instance ToMessage XHtml.Html where-    toContentType _ = B.pack "text/html"-    toMessage = L.pack . XHtml.renderHtml--instance ToMessage Response where-    toResponse = id--instance (Xml a)=>ToMessage a where-    toContentType = toContentType . toXml-    toMessage = toMessage . toPublicXml----    toMessageM = toMessageM . toPublicXml---class MatchMethod m where matchMethod :: m -> Method -> Bool-instance MatchMethod Method where matchMethod m = (== m) -instance MatchMethod [Method] where matchMethod methods = (`elem` methods)-instance MatchMethod (Method -> Bool) where matchMethod f = f -instance MatchMethod () where matchMethod () _ = True---- | flatten turns your arbitrary @m a@ and converts it too--- a @m 'Response'@ with @'toResponse'@-flatten :: (ToMessage a, Functor f) => f a -> f Response-flatten = fmap toResponse---- | This is kinda like a very oddly shaped mapServerPartT or mapWebT--- You probably want one or the other of those.-localContext :: Monad m => (WebT m a -> WebT m' a) -> ServerPartT m a -> ServerPartT m' a-localContext fn hs-    = withRequest $ \rq -> fn (runServerPartT hs rq)----- | Get a header out of the request-getHeaderM :: (ServerMonad m) => String -> m (Maybe B.ByteString)-getHeaderM a = askRq >>= return . (getHeader a)---- | adds headers into the response.---   This method does not overwrite any existing header of---   the same name, hence the name addHeaderM.  If you---   want to replace a header use setHeaderM.-addHeaderM :: (FilterMonad Response m) => String -> String -> m ()-addHeaderM a v = composeFilter $ \res-> addHeader a v res---- | sets a header into the response.  This will replace--- an existing header of the same name.  Use addHeaderM, if you --- want to add more than one header of the same name.-setHeaderM :: (FilterMonad Response m) => String -> String -> m ()-setHeaderM a v = composeFilter $ \res -> setHeader a v res----------------------------------------- guards---- | guard using an arbitrary function on the request-guardRq :: (ServerMonad m, MonadPlus m) => (Request -> Bool) -> m ()-guardRq f = do-    rq <- askRq-    when ( f rq /= True ) mzero ---- | Guard against the method.  This function also guards against--- any remaining path segments.  See methodOnly for the version--- that guards only by method-methodM :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()-methodM meth = methodOnly meth >> nullDir---- | guard against the method only. (as opposed to 'methodM')-methodOnly :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()-methodOnly meth = guardRq $ \rq -> matchMethod meth (rqMethod rq)---- | Guard against the method. Note, this function also guards against any---   remaining path segments.-methodSP :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m b-> m b-methodSP m handle = methodM m >> handle---- | Guard against the method. Note, this function also guards against any--- remaining path segments.  This function id deprecated.  You can probably--- just use methodSP (or methodM) now.-method :: (MatchMethod method, Monad m) => method -> WebT m a -> ServerPartT m a-method m handle = methodSP m (anyRequest handle)-{-# DEPRECATED method "you should be able to use methodSP" #-}---- | Guard against non-empty remaining path segments-nullDir :: (ServerMonad m, MonadPlus m) => m ()-nullDir = guardRq $ \rq -> null (rqPaths rq)---- | Pop a path element and run the @ServerPartT@ if it matches the given string.-dir :: (ServerMonad m, MonadPlus m) => String -> m a -> m a-dir staticPath handle =-    do-        rq <- askRq-        case rqPaths rq of-            (p:xs) | p == staticPath -> localRq (\newRq -> newRq{rqPaths = xs}) handle-                   | otherwise -> mzero-            _ -> mzero---- | Pop a path element and parse it.  Annoyingly enough, rather than just using Read--- (or providing a parser argument), this method uses 'FromReqURI' which is just a wrapper--- for Read.-path :: (FromReqURI a, MonadPlus m, ServerMonad m) => (a -> m b) -> m b-path handle = do-    rq <- askRq-    case rqPaths rq of-        (p:xs) | Just a <- fromReqURI p-                            -> localRq (\newRq -> newRq{rqPaths = xs}) (handle a)-               | otherwise -> mzero-        _ -> mzero---- | grabs the rest of the URL (dirs + query) and passes it to your handler-uriRest :: (ServerMonad m) => (String -> m a) -> m a-uriRest handle = askRq >>= handle . rqURL---- | pops any path element and ignores when chosing a ServerPartT to handle the------ request.-anyPath :: (ServerMonad m, MonadPlus m) => m r -> m r-anyPath x = path $ (\(_::String) -> x)---- | Deprecated. Use 'anyPath'.-anyPath' :: (ServerMonad m, MonadPlus m) => m r -> m r-anyPath' = anyPath-{-# DEPRECATED anyPath' "Use anyPath" #-}---- | used to read parse your request with a RqData (a ReaderT, basically)--- For example here is a simple GET or POST variable based authentication--- guard.  It handles the request with errorHandler if authentication fails.------ @---   myRqData = do---      username <- lookInput \"username\"---      password <- lookInput \"password\"---      return (username, password)---  checkAuth errorHandler = do---      d <- getData myRqDataA---      case d of---          Nothing -> errorHandler---          Just a | isValid a -> mzero---          Just a | otherwise -> errorHandler---  @-getDataFn :: (ServerMonad m) => RqData a -> m (Maybe a)-getDataFn rqData = do-    rq <- askRq-    return $ runReaderT rqData (rqInputs rq, rqCookies rq)---- | An varient of getData that uses FromData to chose your--- RqData for you.  The example from 'getData' becomes:------ @---   myRqData = do---      username <- lookInput \"username\"---      password <- lookInput \"password\"---      return (username, password)---   instance FromData (String,String) where---      fromData = myRqData---   checkAuth errorHandler = do---      d <- getData\'---      case d of---          Nothing -> errorHandler---          Just a | isValid a -> mzero---          Just a | otherwise -> errorHandler--- @-getData :: (ServerMonad m, FromData a) => m (Maybe a)-getData = getDataFn fromData---- | Retrieve data from the input query or the cookies.-withData :: (FromData a, MonadPlus m, ServerMonad m) => (a -> m r) -> m r-withData = withDataFn fromData---- | withDataFn is like with data, but you pass in a RqData monad--- for reading.-withDataFn :: (MonadPlus m, ServerMonad m) => RqData a -> (a -> m r) -> m r-withDataFn fn handle = do-    d <- getDataFn fn-    case d of-        Nothing -> mzero-        Just a -> handle a---- | proxyServe is for creating ServerPartT's that proxy.--- The sole argument [String] is a list of allowed domains for--- proxying.  This matches the domain part of the request--- and the wildcard * can be used. E.g.------  * \"*\" to match anything.------  * \"*.example.com\" to match anything under example.com------  * \"example.com\" to match just example.com---------  TODO: annoyingly enough, this method eventually calls escape, so---  any headers you set won't be used, and the computation immediatly ends.-proxyServe :: (MonadIO m, WebMonad Response m, ServerMonad m, MonadPlus m, FilterMonad Response m) => [String] -> m Response-proxyServe allowed = do-   rq <- askRq-   if cond rq then proxyServe' rq else mzero-   where-   cond rq-     | "*" `elem` allowed = True-     | domain `elem` allowed = True-     | superdomain `elem` wildcards =True-     | otherwise = False-     where-     domain = head (rqPaths rq) -     superdomain = tail $ snd $ break (=='.') domain-     wildcards = (map (drop 2) $ filter ("*." `isPrefixOf`) allowed)---- | Takes a proxy Request and creates a Response.  Your basic proxy--- building block.  See 'unproxify'------ TODO: this would be more useful if it didn\'t call "escape" (e.g. it let you--- modify the response afterwards, or set additional headers)-proxyServe' :: (MonadIO m, FilterMonad Response m, WebMonad Response m) => Request-> m Response-proxyServe' rq = liftIO (getResponse (unproxify rq)) >>=-                either (badGateway . toResponse . show) escape'---- | This is a reverse proxy implementation.--- see 'unrproxify'------ TODO: this would be more useful if it didn\'t call "escape", just like--- proxyServe'-rproxyServe :: (MonadIO m, WebMonad Response m) =>-    String -- ^ defaultHost-    -> [(String, String)] -- ^ map to look up hostname mappings.  For the reverse proxy-    -> ServerPartT m Response -- ^ the result is a ServerPartT that will reverse proxy for you.-rproxyServe defaultHost list  = withRequest $ \rq ->-                liftIO (getResponse (unrproxify defaultHost list rq)) >>=-                either (badGateway . toResponse . show) (escape')---- | Run an IO action and, if it returns @Just@, pass it to the second argument.-require :: (MonadIO m, MonadPlus m) => IO (Maybe a) -> (a -> m r) -> m r-require fn handle = do-    mbVal <- liftIO fn-    case mbVal of-        Nothing -> mzero-        Just a -> handle a---- | A varient of require that can run in any monad, not just IO-requireM :: (MonadTrans t, Monad m, MonadPlus (t m)) => m (Maybe a) -> (a -> t m r) -> t m r-requireM fn handle = do-    mbVal <- lift fn-    case mbVal of-        Nothing -> mzero-        Just a -> handle a---- | Use @cmd@ to transform XML against @xslPath@.---   This function only acts if the content-type is @application\/xml@.-xslt :: (MonadIO m, MonadPlus m, ToMessage r) =>-        XSLTCmd  -- ^ XSLT preprocessor. Usually 'xsltproc' or 'saxon'.-     -> XSLPath      -- ^ Path to xslt stylesheet.-     -> m r -- ^ Affected @ServerParts@.-     -> m Response-xslt cmd xslPath parts = do-    res <- parts-    if toContentType res == B.pack "application/xml"-        then liftM toResponse (doXslt cmd xslPath (toResponse res))-        else return (toResponse res)--doXslt :: (MonadIO m) =>-          XSLTCmd -> XSLPath -> Response -> m Response-doXslt cmd xslPath res = -    do new <- liftIO $ procLBSIO cmd xslPath $ rsBody res-       return $ setHeader "Content-Type" "text/html" $ -              setHeader "Content-Length" (show $ L.length new) $-              res { rsBody = new }---- | deprecated.  Same as 'composeFilter'-modifyResponse :: (FilterMonad a m) => (a -> a) -> m()-modifyResponse = composeFilter-{-# DEPRECATED modifyResponse "Use composeFilter" #-}---- | sets the return code in your response-setResponseCode :: FilterMonad Response m => Int -> m ()-setResponseCode code-    = composeFilter $ \r -> r{rsCode = code}---- | adds the cookie with a timeout to the response-addCookie :: (FilterMonad Response m) => Seconds -> Cookie -> m ()-addCookie sec = (addHeaderM "Set-Cookie") . mkCookieHeader sec---- | adds the list of cookie timeout pairs to the response-addCookies :: (FilterMonad Response m) => [(Seconds, Cookie)] -> m ()-addCookies = mapM_ (uncurry addCookie)---- | same as setResponseCode status >> return val-resp :: (FilterMonad Response m) => Int -> b -> m b-resp status val = setResponseCode status >> return val---- | Respond with @200 OK@.-ok :: (FilterMonad Response m) => a -> m a-ok = resp 200--internalServerError :: (FilterMonad Response m) => a -> m a-internalServerError = resp 500--badGateway :: (FilterMonad Response m) => a -> m a-badGateway = resp 502---- | Respond with @400 Bad Request@.-badRequest :: (FilterMonad Response m) => a -> m a-badRequest = resp 400---- | Respond with @401 Unauthorized@.-unauthorized :: (FilterMonad Response m) => a -> m a-unauthorized = resp 401---- | Respond with @403 Forbidden@.-forbidden :: (FilterMonad Response m) => a -> m a-forbidden = resp 403---- | Respond with @404 Not Found@.-notFound :: (FilterMonad Response m) => a -> m a-notFound = resp 404---- | Respond with @303 See Other@.-seeOther :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res-seeOther uri res = do modifyResponse $ redirect 303 uri-                      return res---- | Respond with @302 Found@.-found :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res-found uri res = do modifyResponse $ redirect 302 uri-                   return res---- | Respond with @301 Moved Permanently@.-movedPermanently :: (FilterMonad Response m, ToSURI a) => a -> res -> m res-movedPermanently uri res = do modifyResponse $ redirect 301 uri-                              return res---- | Respond with @307 Temporary Redirect@.-tempRedirect :: (FilterMonad Response m, ToSURI a) => a -> res -> m res-tempRedirect val res = do modifyResponse $ redirect 307 val-                          return res---- | deprecated.  Just use msum-multi :: Monad m => [ServerPartT m a] -> ServerPartT m a-multi = msum-{-# DEPRECATED multi "Use msum instead" #-}---- | what is this for, exactly?  I don't understand why @Show a@ is even in the context--- This appears to do nothing at all.-debugFilter :: (MonadIO m, Show a) => ServerPartT m a -> ServerPartT m a-debugFilter handle =-    withRequest $ \rq -> do-                    r <- runServerPartT handle rq-                    return r---- | a constructor for a ServerPartT when you don't care about the request-anyRequest :: Monad m => WebT m a -> ServerPartT m a-anyRequest x = withRequest $ \_ -> x---- | again, why is this useful?-applyRequest :: (ToMessage a, Monad m) =>-                ServerPartT m a -> Request -> Either (m Response) b-applyRequest hs = simpleHTTP'' hs >>= return . Left---- | a simple HTTP basic authentication guard-basicAuth :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadPlus m) =>-   String -- ^ the realm name-   -> M.Map String String -- ^ the username password map-   -> m a -- ^ the part to guard-   -> m a-basicAuth realmName authMap xs = basicAuthImpl `mplus` xs-  where-    basicAuthImpl = do-        aHeader <- getHeaderM "authorization"-        case aHeader of-            Nothing -> err-            Just x -> case parseHeader x of-                (name, ':':password) | validLogin name password -> mzero-                                     | otherwise -> err-                _  -> err-    validLogin name password = M.lookup name authMap == Just password-    parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6-    headerName  = "WWW-Authenticate"-    headerValue = "Basic realm=\"" ++ realmName ++ "\""-    err = do-        unauthorized ()-        setHeaderM headerName headerValue-        escape' $ toResponse "Not authorized"------------------------------------------------------------------- Query/Post data validating------------------------------------------------------------------- | Useful inside the RqData monad.  Gets the named input parameter (either--- from a POST or a GET)-lookInput :: String -> RqData Input-lookInput name-    = do inputs <- asks fst-         case lookup name inputs of-           Nothing -> fail "input not found"-           Just i  -> return i---- | Gets the named input parameter as a lazy byte string-lookBS :: String -> RqData L.ByteString-lookBS = fmap inputValue . lookInput---- | Gets the named input as a String-look :: String -> RqData String-look = fmap L.unpack . lookBS---- | Gets the named cookie--- the cookie name is case insensitive-lookCookie :: String -> RqData Cookie-lookCookie name-    = do cookies <- asks snd-         case lookup (map toLower name) cookies of -- keys are lowercased-           Nothing -> fail "cookie not found"-           Just c  -> return c---- | gets the named cookie as a string-lookCookieValue :: String -> RqData String-lookCookieValue = fmap cookieValue . lookCookie---- | gets the named cookie as the requested Read type-readCookieValue :: Read a => String -> RqData a-readCookieValue name = readM =<< fmap cookieValue (lookCookie name)---- | like look, but Reads for you.-lookRead :: Read a => String -> RqData a-lookRead name = readM =<< look name---- | gets all the input parameters, and converts them to a string-lookPairs :: RqData [(String,String)]-lookPairs = asks fst >>= return . map (\(n,vbs)->(n,L.unpack $ inputValue vbs))-------------------------------------------------------------------- Error Handling------------------------------------------------------------------- | This ServerPart modifier enables the use of throwError and catchError inside the---   WebT actions, by adding the ErrorT monad transformer to the stack.------   You can wrap the complete second argument to 'simpleHTTP' in this function.----errorHandlerSP :: (Monad m, Error e) => (Request -> e -> WebT m a) -> ServerPartT (ErrorT e m) a -> ServerPartT m a -errorHandlerSP handler sps = withRequest $ \req -> mkWebT $ do-			eer <- runErrorT $ ununWebT $ runServerPartT sps req-			case eer of-				Left err -> ununWebT (handler req err)-				Right res -> return res-{-# DEPRECATED errorHandlerSP "Use spUnwrapErrorT" #-}---- | An example error Handler to be used with 'spUnWrapErrorT', which returns the---   error message as a plain text message to the browser.------   Another possibility is to store the error message, e.g. as a FlashMsg, and---   then redirect the user somewhere.-simpleErrorHandler :: (Monad m) => String -> ServerPartT m Response-simpleErrorHandler err = ok $ toResponse $ ("An error occured: " ++ err)---- | This is a for use with mapServerPartT\'  It it unwraps--- the interior monad for use with simpleHTTP.  If you--- have a ServerPartT (ErrorT e m) a, this will convert--- that monad into a ServerPartT m a.  Used with--- mapServerPartT\' to allow throwError and catchError inside your--- monad.  Eg.--- --- @---   simpleHTTP conf $ mapServerPartT\' (spUnWrapErrorT failurePart)  $ myPart \`catchError\` errorPart--- @--- --- Note that @failurePart@ will only be run if errorPart threw an error--- so it doesn\'t have to be very complex.-spUnwrapErrorT:: Monad m =>-        (e -> ServerPartT m a)-        -> Request-        -> ErrorT e m (Maybe (Either Response a, FilterFun Response))-        -> m (Maybe (Either Response a, FilterFun Response))-spUnwrapErrorT handler rq = \x -> do-    err <- runErrorT x-    case err of-        Left e -> ununWebT $ runServerPartT (handler e) rq-        Right a -> return a------------------------------------------------------------------- * Output validation------------------------------------------------------------------- |Set the validator which should be used for this particular 'Response'--- when validation is enabled.------ Calling this function does not enable validation. That can only be--- done by enabling the validation in the 'Conf' that is passed to--- 'simpleHTTP'.------ You do not need to call this function if the validator set in--- 'Conf' does what you want already.------ Example: (use 'noopValidator' instead of the default supplied by 'validateConf')------ @---  simpleHTTP validateConf . anyRequest $ ok . setValidator noopValidator =<< htmlPage--- @------ See also: 'validateConf', 'wdgHTMLValidator', 'noopValidator', 'lazyProcValidator'-setValidator :: (Response -> IO Response) -> Response -> Response-setValidator v r = r { rsValidator = Just v }---- |ServerPart version of 'setValidator'------ Example: (Set validator to 'noopValidator')------ @---   simpleHTTP validateConf $ setValidatorSP noopValidator (dir "ajax" ... )--- @------ See also: 'setValidator'-setValidatorSP :: (Monad m, ToMessage r) => (Response -> IO Response) -> m r -> m Response-setValidatorSP v sp = return . setValidator v . toResponse =<< sp---- |This extends 'nullConf' by enabling validation and setting--- 'wdgHTMLValidator' as the default validator for @text\/html@.------ Example:------ @---  simpleHTTP validateConf . anyRequest $ ok htmlPage--- @-validateConf :: Conf-validateConf = nullConf { validator = Just wdgHTMLValidator }---- |Actually perform the validation on a 'Response'--- --- Run the validator specified in the 'Response'. If none is provide--- use the supplied default instead. ------ Note: This function will run validation unconditionally. You--- probably want 'setValidator' or 'validateConf'.-runValidator :: (Response -> IO Response) -> Response -> IO Response-runValidator defaultValidator r =-    case rsValidator r of-      Nothing -> defaultValidator r-      (Just altValidator) -> altValidator r---- |Validate @text\/html@ content with @WDG HTML Validator@.------ This function expects the executable to be named @validate@--- and it must be in the default @PATH@.------ See also: 'setValidator', 'validateConf', 'lazyProcValidator'-wdgHTMLValidator :: (MonadIO m, ToMessage r) => r -> m Response-wdgHTMLValidator = liftIO . lazyProcValidator "validate" ["-w","--verbose","--charset=utf-8"] Nothing Nothing handledContentTypes . toResponse-    where-      handledContentTypes (Just ct) = elem (takeWhile (\c -> c /= ';' && c /= ' ') (B.unpack ct)) [ "text/html", "application/xhtml+xml" ]-      handledContentTypes Nothing = False---- |A validator which always succeeds.------ Useful for selectively disabling validation. For example, if you--- are sending down HTML fragments to an AJAX application and the--- default validator only understands complete documents.-noopValidator :: Response -> IO Response-noopValidator = return---- |Validate the 'Response' using an external application.--- --- If the external application returns 0, the original response is--- returned unmodified. If the external application returns non-zero, a 'Response'--- containing the error messages and original response body is--- returned instead.------ This function also takes a predicate filter which is applied to the--- content-type of the response. The filter will only be applied if--- the predicate returns true.------ NOTE: This function requirse the use of -threaded to avoid blocking.--- However, you probably need that for Happstack anyway.--- --- See also: 'wdgHTMLValidator'-lazyProcValidator :: FilePath -- ^ name of executable-               -> [String] -- ^ arguements to pass to the executable-               -> Maybe FilePath -- ^ optional path to working directory-               -> Maybe [(String, String)] -- ^ optional environment (otherwise inherit)-               -> (Maybe B.ByteString -> Bool) -- ^ content-type filter-               -> Response -- ^ Response to validate-               -> IO Response-lazyProcValidator exec args wd env mimeTypePred response-    | mimeTypePred (getHeader "content-type" response) =-        do (inh, outh, errh, ph) <- runInteractiveProcess exec args wd env-           out <- hGetContents outh-           err <- hGetContents errh-           forkIO $ do L.hPut inh (rsBody response)-                       hClose inh-           forkIO $ evaluate (length out) >> return ()-           forkIO $ evaluate (length err) >> return ()-           ec <- waitForProcess ph-           case ec of-             ExitSuccess     -> return response-             (ExitFailure _) -> -                 return $ toResponse (unlines ([ "ExitCode: " ++ show ec-                                               , "stdout:"-                                               , out-                                               , "stderr:"-                                               , err-                                               , "input:"-                                               ] ++ -                                               showLines (rsBody response)))-    | otherwise = return response-    where-      column = "  " ++ (take 120 $ concatMap  (\n -> "         " ++ show n) (drop 1 $ cycle [0..9::Int]))-      showLines :: L.ByteString -> [String]-      showLines string = column : zipWith (\n -> \l  -> show n ++ " " ++ (L.unpack l)) [1::Integer ..] (L.lines string)--mkFailMessage :: (FilterMonad Response m, WebMonad Response m) => String -> m b-mkFailMessage s = do-    ignoreFilters-    internalServerError ()-    setHeaderM "Content-Type" "text/html"-    res <- return $ toResponse $ failHtml s-    finishWith $ res--failHtml:: String->String-failHtml errString = "<html><head><title>Happstack "-    ++ ver ++ " Internal Server Error</title>"-    ++ "<body><h1>Happstack " ++ ver ++ "</h1>"-    ++ "<p>Something went wrong here<br />"-    ++ "Internal server error<br />"-    ++ "Everything has stopped</p>"-    ++ "<p>The error was \"" ++ errString ++ "\"</p></body></html>"-    where ver = DV.showVersion Cabal.version--notFoundHtml :: String-notFoundHtml = "<html><head><title>Happstack "-    ++ ver ++ " File not found</title>"-    ++ "<body><h1>Happstack " ++ ver ++ "</h1>"-    ++ "<p>Your file is not found<br />"-    ++ "To try again is useless<br />"-    ++ "It is just not here</p>"-    ++ "</body></html>"-    where ver = DV.showVersion Cabal.version+{-# LANGUAGE CPP #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Happstack.Server.SimpleHTTP+-- Copyright   :  (c) Happstack.com 2010; (c) HAppS Inc 2007+-- License     :  BSD-like+--+-- Maintainer  :  Happstack team <happs@googlegroups.com>+-- Stability   :  provisional+-- Portability :  requires mtl+--+-- 'simpleHTTP' is a self-contained HTTP server which can be used to+-- run a 'ServerPart'.+--+-- A very simple, \"Hello World!\" web app looks like:+--+-- > import Happstack.Server+-- > main = simpleHTTP nullConf $ ok "Hello World!"+--+-- By default the server will listen on port 8000. Run the app and point your browser at: <http:\/\/localhost:8000\/>+--+-- For FastCGI support see: <http:\/\/hackage.haskell.org\/package\/happstack-fastcgi>+-----------------------------------------------------------------------------+module Happstack.Server.SimpleHTTP+    ( -- * SimpleHTTP+      simpleHTTP+    , simpleHTTP'+    , simpleHTTP''+    , simpleHTTPWithSocket+    , simpleHTTPWithSocket'+    , bindPort+    , bindIPv4+    , parseConfig+    , runWebT+    , waitForTermination+    -- * Re-exported modules+    -- ** Basic ServerMonad functionality+    , module Happstack.Server.Monads+    -- ** HTTP Realm Authentication+    , module Happstack.Server.Auth+    -- ** Create and Set Cookies (see also "Happstack.Server.RqData")+    , module Happstack.Server.Cookie+    -- ** Error Handling+    , module Happstack.Server.Error+    -- ** Creating Responses+    , module Happstack.Server.Response+    -- ** Request Routing+    , module Happstack.Server.Routing+    -- ** Looking up values in Query String, Request Body, and Cookies+    , module Happstack.Server.RqData+    -- ** Output Validation+    , module Happstack.Server.Validation+    , module Happstack.Server.Types+--    , module Happstack.Server.Internal.Monads++    ) where++-- re-exports++import Happstack.Server.Auth+import Happstack.Server.Monads+import Happstack.Server.Cookie+import Happstack.Server.Error+import Happstack.Server.Types+import Happstack.Server.Routing+import Happstack.Server.RqData+import Happstack.Server.Response+import Happstack.Server.Validation++import Control.Monad+import Data.Maybe                                (fromMaybe)+import qualified Data.Version                    as DV+import Happstack.Server.Internal.Monads          (FilterFun, WebT(..), unFilterFun, runServerPartT, ununWebT)+import qualified Happstack.Server.Internal.Listen as Listen (listen, listen',listenOn, listenOnIPv4) -- So that we can disambiguate 'Writer.listen'+import Network.Socket                            (Socket)+import qualified Paths_happstack_server          as Cabal+import System.Console.GetOpt                     ( OptDescr(Option)+                                                 , ArgDescr(ReqArg)+                                                 , ArgOrder(Permute)+                                                 , getOpt+                                                 )+#ifdef UNIX+import Control.Concurrent.MVar+import System.Posix.Signals hiding (Handler)+import System.Posix.IO ( stdInput )+import System.Posix.Terminal ( queryTerminal )+#endif++-- | An array of 'OptDescr', useful for processing command line+-- options into an 'Conf' for 'simpleHTTP'.+ho :: [OptDescr (Conf -> Conf)]+ho = [Option [] ["http-port"] (ReqArg (\h c -> c { port = readDec' h }) "port") "port to bind http server"]++-- | Parse command line options into a 'Conf'.+parseConfig :: [String] -> Either [String] Conf+parseConfig args+    = case getOpt Permute ho args of+        (flags,_,[]) -> Right $ foldr ($) nullConf flags+        (_,_,errs)   -> Left errs++-- |start the server, and handle requests using the supplied+-- 'ServerPart'.+--+-- This function will not return, though it may throw an exception.+--+-- NOTE: The server will only listen on IPv4 due to portability issues+-- in the "Network" module. For IPv6 support, use+-- 'simpleHTTPWithSocket' with custom socket.+simpleHTTP :: (ToMessage a) => Conf -> ServerPartT IO a -> IO ()+simpleHTTP = simpleHTTP' id++-- | A combination of 'simpleHTTP''' and 'mapServerPartT'.  See+-- 'mapServerPartT' for a discussion of the first argument of this+-- function.+--+-- NOTE: This function always binds to IPv4 ports until Network+-- module is fixed to support IPv6 in a portable way. Use+-- 'simpleHTTPWithSocket' with custom socket if you want different+-- behaviour.+simpleHTTP' :: (ToMessage b, Monad m, Functor m) => (UnWebT m a -> UnWebT IO b)+            -> Conf -> ServerPartT m a -> IO ()+simpleHTTP' toIO conf hs =+    Listen.listen conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req))++-- | Generate a result from a 'ServerPartT' and a 'Request'. This is+-- mainly used by CGI (and fast-cgi) wrappers.+simpleHTTP'' :: (ToMessage b, Monad m, Functor m) => ServerPartT m b -> Request -> m Response+simpleHTTP'' hs req =  (runWebT $ runServerPartT hs req) >>= (return . (maybe standardNotFound id))+    where+        standardNotFound = setHeader "Content-Type" "text/html" $ (toResponse notFoundHtml){rsCode=404}++-- | Run 'simpleHTTP' with a previously bound socket. Useful if you+-- want to run happstack as user on port 80. Use something like this:+--+-- > import System.Posix.User (setUserID, UserEntry(..), getUserEntryForName)+-- >+-- > main = do+-- >     let conf = nullConf { port = 80 }+-- >     socket <- bindPort conf+-- >     -- do other stuff as root here+-- >     getUserEntryForName "www" >>= setUserID . userID+-- >     -- finally start handling incoming requests+-- >     tid <- forkIO $ simpleHTTPWithSocket socket Nothing conf impl+--+-- Note: It's important to use the same conf (or at least the same+-- port) for 'bindPort' and 'simpleHTTPWithSocket'.+--+-- see also: 'bindPort', 'bindIPv4'+simpleHTTPWithSocket :: (ToMessage a) => Socket -> Conf -> ServerPartT IO a -> IO ()+simpleHTTPWithSocket = simpleHTTPWithSocket' id++-- | Like 'simpleHTTP'' with a socket.+simpleHTTPWithSocket' :: (ToMessage b, Monad m, Functor m) => (UnWebT m a -> UnWebT IO b)+                      -> Socket -> Conf -> ServerPartT m a -> IO ()+simpleHTTPWithSocket' toIO socket conf hs =+    Listen.listen' socket conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req))++-- | Bind port and return the socket for use with 'simpleHTTPWithSocket'. This+-- function always binds to IPv4 ports until Network module is fixed+-- to support IPv6 in a portable way.+bindPort :: Conf -> IO Socket+bindPort conf = Listen.listenOn (port conf)++-- | Bind to ip and port and return the socket for use with 'simpleHTTPWithSocket'.+--+-- >+-- > import Happstack.Server+-- >+-- > main = do let conf = nullConf+-- >               addr = "127.0.0.1"+-- >           s <- bindIPv4 addr (port conf)+-- >           simpleHTTPWithSocket s conf $ ok $ toResponse $+-- >             "now listening on ip addr " ++ addr +++-- >             " and port " ++ show (port conf)+--+bindIPv4 :: String  -- ^ IP address to bind to (must be an IP address and not a host name)+         -> Int     -- ^ port number to bind to+         -> IO Socket+bindIPv4 addr prt = Listen.listenOnIPv4 addr prt++-- | Takes your 'WebT', if it is 'mempty' it returns 'Nothing' else it+-- converts the value to a 'Response' and applies your filter to it.+runWebT :: forall m b. (Functor m, ToMessage b) => WebT m b -> m (Maybe Response)+runWebT = (fmap . fmap) appFilterToResp . ununWebT+    where+      appFilterToResp :: (Either Response b, FilterFun Response) -> Response+      appFilterToResp (e, ff) = unFilterFun ff $ either id toResponse e++notFoundHtml :: String+notFoundHtml =+    "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">"+    ++ "<html><head><title>Happstack "+    ++ ver ++ " File not found</title></head>"+    ++ "<body><h1>Happstack " ++ ver ++ "</h1>"+    ++ "<p>Your file is not found<br>"+    ++ "To try again is useless<br>"+    ++ "It is just not here</p>"+    ++ "</body></html>"+    where ver = DV.showVersion Cabal.version+++-- | Wait for a signal.+--   On unix, a signal is sigINT or sigTERM (aka Control-C).+--+-- On windows, the signal is entering: e <return>+waitForTermination :: IO ()+waitForTermination+    = do+#ifdef UNIX+         istty <- queryTerminal stdInput+         mv <- newEmptyMVar+         void $ installHandler softwareTermination (CatchOnce (putMVar mv ())) Nothing+         void $ installHandler lostConnection      (CatchOnce (putMVar mv ())) Nothing+         case istty of+           True  -> void $ installHandler keyboardSignal (CatchOnce (putMVar mv ())) Nothing+           False -> return ()+         takeMVar mv+#else+         let loop 'e' = return ()+             loop _   = getChar >>= loop+         loop 'c'+#endif
− src/Happstack/Server/StdConfig.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Happstack.Server.StdConfig where--import Control.Monad.Trans-import Control.Monad-import Happstack.Server.SimpleHTTP-import Happstack.Server.HTTP.FileServe---- | Is equal to "haskell/Main"-binarylocation :: String-binarylocation = "haskell/Main"---- | Is equal to "public/log"-loglocation :: String-loglocation = "public/log"---- | Convenience function around 'errorwrapper'--- with the default binary location set to 'binarylocation' and the--- log location set to 'loglocation'. -errWrap :: (MonadPlus m, FilterMonad Response m, MonadIO m) => m Response-errWrap =  errorwrapper binarylocation loglocation---stateFuns -- main actually has state so you can just import them
+ src/Happstack/Server/Types.hs view
@@ -0,0 +1,19 @@+module Happstack.Server.Types+    (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..),+     takeRequestBody, readInputsBody,+     rqURL, mkHeaders,+     getHeader, getHeaderBS, getHeaderUnsafe,+     hasHeader, hasHeaderBS, hasHeaderUnsafe,+     setHeader, setHeaderBS, setHeaderUnsafe,+     addHeader, addHeaderBS, addHeaderUnsafe,+     setRsCode, -- setCookie, setCookies,+     LogAccess, logMAccess, Conf(..), nullConf, result, resultBS,+     redirect, -- redirect_, redirect', redirect'_,+     isHTTP1_0, isHTTP1_1,+     RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength,+     HttpVersion(..), Length(..), Method(..), Headers, continueHTTP,+     Host, ContentType(..),+     readDec', fromReadS, FromReqURI(..)+    ) where++import Happstack.Server.Internal.Types
+ src/Happstack/Server/Validation.hs view
@@ -0,0 +1,135 @@+-- | Support for validating server output on-the-fly. Validators can be configured on a per content-type basis.+module Happstack.Server.Validation where++import Control.Concurrent                        (forkIO)+import Control.Exception                         (evaluate)+import Control.Monad+import Control.Monad.Trans                       (MonadIO(liftIO))+import qualified Data.ByteString.Char8           as B+import qualified Data.ByteString.Lazy.Char8      as L+import Happstack.Server.Types                    (Conf(..), Response(..), getHeader, nullConf)+import Happstack.Server.Response                 (ToMessage, toResponse)+import System.Exit                               (ExitCode(ExitSuccess, ExitFailure))+import System.IO                                 (hGetContents, hClose)+import System.Process                            (runInteractiveProcess, waitForProcess)++-- | Set the validator which should be used for this particular+-- 'Response' when validation is enabled.+--+-- Calling this function does not enable validation. That can only be+-- done by enabling the validation in the 'Conf' that is passed to+-- 'simpleHTTP'.+--+-- You do not need to call this function if the validator set in+-- 'Conf' does what you want already.+--+-- Example: (use 'noopValidator' instead of the default supplied by+-- 'validateConf')+--+-- > simpleHTTP validateConf $ ok . setValidator noopValidator =<< htmlPage+--+-- See also: 'validateConf', 'wdgHTMLValidator', 'noopValidator',+-- 'lazyProcValidator'.+setValidator :: (Response -> IO Response) -> Response -> Response+setValidator v r = r { rsValidator = Just v }++-- | 'ServerPart' version of 'setValidator'.+--+-- Example: (Set validator to 'noopValidator')+--+-- >  simpleHTTP validateConf $ setValidatorSP noopValidator (dir "ajax" ... )+--+setValidatorSP :: (Monad m, ToMessage r) => (Response -> IO Response) -> m r -> m Response+setValidatorSP v sp = return . setValidator v . toResponse =<< sp++-- | Extend 'nullConf' by enabling validation and setting+-- 'wdgHTMLValidator' as the default validator for @text\/html@.+--+-- Example:+--+-- > simpleHTTP validateConf . anyRequest $ ok htmlPage+--+validateConf :: Conf+validateConf = nullConf { validator = Just wdgHTMLValidator }++-- | Actually perform the validation on a 'Response'.+--+-- Run the validator specified in the 'Response'. If none is provide+-- use the supplied default instead.+--+-- Note: This function will run validation unconditionally. You+-- probably want 'setValidator' or 'validateConf'.+runValidator :: (Response -> IO Response) -> Response -> IO Response+runValidator defaultValidator r =+    case rsValidator r of+      Nothing -> defaultValidator r+      (Just altValidator) -> altValidator r++-- | Validate @text\/html@ content with @WDG HTML Validator@.+--+-- This function expects the executable to be named @validate@ and it+-- must be in the default @PATH@.+--+-- See also: 'setValidator', 'validateConf', 'lazyProcValidator'.+wdgHTMLValidator :: (MonadIO m, ToMessage r) => r -> m Response+wdgHTMLValidator = liftIO . lazyProcValidator "validate" ["-w","--verbose","--charset=utf-8"] Nothing Nothing handledContentTypes . toResponse+    where+      handledContentTypes (Just ct) = elem (takeWhile (\c -> c /= ';' && c /= ' ') (B.unpack ct)) [ "text/html", "application/xhtml+xml" ]+      handledContentTypes Nothing = False++-- | A validator which always succeeds.+--+-- Useful for selectively disabling validation. For example, if you+-- are sending down HTML fragments to an AJAX application and the+-- default validator only understands complete documents.+noopValidator :: Response -> IO Response+noopValidator = return++-- | Validate the 'Response' using an external application.+--+-- If the external application returns 0, the original response is+-- returned unmodified. If the external application returns non-zero,+-- a 'Response' containing the error messages and original response+-- body is returned instead.+--+-- This function also takes a predicate filter which is applied to the+-- content-type of the response. The filter will only be applied if+-- the predicate returns true.+--+-- NOTE: This function requires the use of -threaded to avoid+-- blocking.  However, you probably need that for Happstack anyway.+--+-- See also: 'wdgHTMLValidator'.+lazyProcValidator :: FilePath -- ^ name of executable+               -> [String] -- ^ arguments to pass to the executable+               -> Maybe FilePath -- ^ optional path to working directory+               -> Maybe [(String, String)] -- ^ optional environment (otherwise inherit)+               -> (Maybe B.ByteString -> Bool) -- ^ content-type filter+               -> Response -- ^ Response to validate+               -> IO Response+lazyProcValidator exec args wd env mimeTypePred response+    | mimeTypePred (getHeader "content-type" response) =+        do (inh, outh, errh, ph) <- runInteractiveProcess exec args wd env+           out <- hGetContents outh+           err <- hGetContents errh+           void $ forkIO $ do L.hPut inh (rsBody response)+                              hClose inh+           void $ forkIO $ evaluate (length out) >> return ()+           void $ forkIO $ evaluate (length err) >> return ()+           ec <- waitForProcess ph+           case ec of+             ExitSuccess     -> return response+             (ExitFailure _) ->+                 return $ toResponse (unlines ([ "ExitCode: " ++ show ec+                                               , "stdout:"+                                               , out+                                               , "stderr:"+                                               , err+                                               , "input:"+                                               ] +++                                               showLines (rsBody response)))+    | otherwise = return response+    where+      column = "  " ++ (take 120 $ concatMap  (\n -> "         " ++ show n) (drop 1 $ cycle [0..9::Int]))+      showLines :: L.ByteString -> [String]+      showLines string = column : zipWith (\n -> \l  -> show n ++ " " ++ (L.unpack l)) [1::Integer ..] (L.lines string)
− src/Happstack/Server/XSLT.hs 
@@ -1,157 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances , UndecidableInstances,-             DeriveDataTypeable, MultiParamTypeClasses, CPP, ScopedTypeVariables,-    PatternSignatures #-}-module Happstack.Server.XSLT-    (xsltFile, xsltString, xsltElem, xsltFPS, xsltFPSIO, XSLPath,-     xsltproc,saxon,procFPSIO,procLBSIO,XSLTCommand,XSLTCmd-    ) where---import System.Log.Logger--import Happstack.Server.MinHaXML-import Happstack.Util.Common(runCommand)-import Control.Exception.Extensible(bracket,try,SomeException)-import qualified Data.ByteString.Char8 as P-import qualified Data.ByteString.Lazy.Char8 as L-import System.Directory(removeFile)-import System.Environment(getEnv)-import System.IO-import System.IO.Unsafe(unsafePerformIO)-import Text.XML.HaXml.Verbatim(verbatim)-import Happstack.Data hiding (Element)--logMX :: Priority -> String -> IO ()-logMX = logM "Happstack.Server.XSLT"--type XSLPath = FilePath--$(deriveAll [''Show,''Read,''Default, ''Eq, ''Ord]-   [d|-       data XSLTCmd = XSLTProc | Saxon -    |]-   )--xsltCmd :: XSLTCmd-           -> XSLPath-           -> FilePath-           -> FilePath-           -> (FilePath, [String])-xsltCmd XSLTProc = xsltproc'-xsltCmd Saxon = saxon'---- | Uses 'xsltString' to transform the given XML 'Element' into a--- a 'String'.    -xsltElem :: XSLPath -> Element -> String-xsltElem xsl = xsltString xsl . verbatim---procLBSIO :: XSLTCmd -> XSLPath -> L.ByteString -> IO L.ByteString-procLBSIO xsltp' xsl inp = -    withTempFile "happs-src.xml" $ \sfp sh -> do-    withTempFile "happs-dst.xml" $ \dfp dh -> do-    let xsltp = xsltCmd xsltp'-    L.hPut sh inp-    hClose sh-    hClose dh-    xsltFileEx xsltp xsl sfp dfp-    s <- L.readFile dfp-    logMX DEBUG (">>> XSLT: result: "++ show s)-    return s---procFPSIO :: XSLTCommand-             -> XSLPath-             -> [P.ByteString]-             -> IO [P.ByteString]-procFPSIO xsltp xsl inp = -    withTempFile "happs-src.xml" $ \sfp sh -> do-    withTempFile "happs-dst.xml" $ \dfp dh -> do-    mapM_ (P.hPut sh) inp-    hClose sh-    hClose dh-    xsltFileEx xsltp xsl sfp dfp-    s <- P.readFile dfp-    logMX DEBUG (">>> XSLT: result: "++ show s)-    return [s]---- | Performs an XSL transformation with lists of ByteStrings instead of--- a String.-xsltFPS :: XSLPath -> [P.ByteString] -> [P.ByteString]-xsltFPS xsl = unsafePerformIO . xsltFPSIO xsl---- | Equivalent to 'xsltFPS' but does not hide the inherent IO of the low-level--- ByteString operations.-xsltFPSIO :: XSLPath -> [P.ByteString] -> IO [P.ByteString]-xsltFPSIO xsl inp = -    withTempFile "happs-src.xml" $ \sfp sh -> do-    withTempFile "happs-dst.xml" $ \dfp dh -> do-    mapM_ (P.hPut sh) inp-    hClose sh-    hClose dh-    xsltFile xsl sfp dfp-    s <- P.readFile dfp-    logMX DEBUG (">>> XSLT: result: "++ show s)-    return [s]---- | Uses the provided xsl file to transform the given string.--- This function creates temporary files during its execution, but--- guarantees their cleanup.-xsltString :: XSLPath -> String -> String-xsltString xsl inp = unsafePerformIO $-    withTempFile "happs-src.xml" $ \sfp sh -> do-    withTempFile "happs-dst.xml" $ \dfp dh -> do-    hPutStr sh inp-    hClose sh-    hClose dh-    xsltFile xsl sfp dfp-    s <- readFileStrict dfp-    logMX DEBUG (">>> XSLT: result: "++ show s)-    return s---- | Note that the xsl file must have .xsl suffix.-xsltFile :: XSLPath -> FilePath -> FilePath -> IO ()-xsltFile = xsltFileEx xsltproc'---- | Use @xsltproc@ to transform XML.-xsltproc :: XSLTCmd-xsltproc = XSLTProc-xsltproc' :: XSLTCommand-xsltproc' dst xsl src = ("xsltproc",["-o",dst,xsl,src])----- | Use @saxon@ to transform XML.-saxon :: XSLTCmd-saxon = Saxon-saxon' :: XSLTCommand-saxon' dst xsl src = ("java -classpath /usr/share/java/saxon.jar",-                     ["com.icl.saxon.StyleSheet"-                     ,"-o",dst,src,xsl])-                        -type XSLTCommand = XSLPath -> FilePath -> FilePath -> (FilePath,[String])-xsltFileEx   :: XSLTCommand -> XSLPath -> FilePath -> FilePath -> IO ()-xsltFileEx xsltp xsl src dst = do-    let msg = (">>> XSLT: Starting xsltproc " ++ unwords ["-o",dst,xsl,src])-    logMX DEBUG msg-    uncurry runCommand $ xsltp dst xsl src-    logMX DEBUG (">>> XSLT: xsltproc done")---- Utilities--withTempFile :: String -> (FilePath -> Handle -> IO a) -> IO a-withTempFile str hand = bracket (openTempFile tempDir str) (removeFile . fst) (uncurry hand)--readFileStrict :: FilePath -> IO String-readFileStrict fp = do-    let fseqM [] = return [] -        fseqM xs = last xs `seq` return xs-    fseqM =<< readFile fp--{-# NOINLINE tempDir #-}-tempDir :: FilePath-tempDir = unsafePerformIO $ tryAny [getEnv "TEMP",getEnv "TMP"] err-    where err = return "/tmp"--tryAny :: [IO a] -> IO a -> IO a-tryAny [] c     = c-tryAny (x:xs) c = either (\(_::SomeException) -> tryAny xs c) return =<< try x
tests/Happstack/Server/Tests.hs view
@@ -1,41 +1,262 @@ -- |HUnit tests and QuickQuick properties for Happstack.Server.* module Happstack.Server.Tests (allTests) where -import Test.HUnit as HU (Test(..),(~:),(~?),(@?=))+import qualified Codec.Compression.GZip as GZ+import qualified Codec.Compression.Zlib as Z+import Control.Arrow ((&&&))+import Control.Applicative ((<$>))+import Control.Concurrent.MVar+import Control.Monad+import Data.ByteString.Lazy.Char8     (pack, unpack)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy  as L+import Data.List (intercalate)+import qualified Data.Map              as Map+import Happstack.Server                      ( Request(..), Method(..), Response(..), ServerPart, Headers, RqBody(Body), HttpVersion(..)+                                             , ToMessage(..), HeaderPair(..), ok, dir, simpleHTTP'', composeFilter, noContentLength, matchMethod+                                             , look, getDataFn)+import Happstack.Server.FileServe.BuildingBlocks (sendFileResponse) import Happstack.Server.Cookie-import Happstack.Server.Parts+import Happstack.Server.Internal.Compression+import Happstack.Server.Internal.Cookie+import Happstack.Server.Internal.Multipart+import Happstack.Server.Internal.MessageWrap+import Happstack.Server.Internal.RFC822Headers (ContentDisposition(..), parseContentDisposition)+import Happstack.Server.SURI(ToSURI(..), path, query)+import Test.HUnit as HU (Test(..), (~:), (@?=), (@=?), assertEqual) import Text.ParserCombinators.Parsec --- |All of the tests for happstack-util should be listed here. +-- |All of the tests for happstack-util should be listed here. allTests :: Test-allTests = -    "happstack-server tests" ~: [cookieParserTest, acceptEncodingParserTest]+allTests =+    "happstack-server tests" ~: [ cookieParserTest+                                , acceptEncodingParserTest+                                , multipart+                                , compressFilterResponseTest+                                , matchMethodTest+                                , cookieHeaderOrderTest+                                , pContentDispositionFilename+                                , applicativeTest+                                ]  cookieParserTest :: Test-cookieParserTest = +cookieParserTest =     "cookieParserTest" ~:     [parseCookies "$Version=1;Cookie1=value1;$Path=\"/testpath\";$Domain=example.com;cookie2=value2"         @?= (Right [-            Cookie "1" "/testpath" "example.com" "cookie1" "value1"-          , Cookie "1" "" "" "cookie2" "value2"+            Cookie "1" "/testpath" "example.com" "cookie1" "value1" False False SameSiteNoValue False+          , Cookie "1" "" "" "cookie2" "value2" False False SameSiteNoValue False           ])     ,parseCookies "  \t $Version = \"1\" ; cookie1 = \"randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|\" , $Path=/  "         @?= (Right [-            Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|"+            Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/|" False False SameSiteNoValue False           ])     ,parseCookies " cookie1 = value1  "         @?= (Right [-            Cookie "" "" "" "cookie1" "value1"+            Cookie "" "" "" "cookie1" "value1" False False SameSiteNoValue False           ])     ,parseCookies " $Version=\"1\";buggygooglecookie = valuewith=whereitshouldnotbe  "         @?= (Right [-            Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe"+            Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" False False SameSiteNoValue False           ])+    , parseCookies "foo=\"\\\"bar\\\"\""+        @?= (Right [+              Cookie "" "" ""  "foo" "\"bar\"" False False SameSiteNoValue False+             ])     ]  acceptEncodingParserTest :: Test acceptEncodingParserTest =     "acceptEncodingParserTest" ~:-    [either (Left . show) Right (parse encodings "" " gzip;q=1,*, compress ; q = 0.5 ")-        @?= (Right [("gzip", Just 1),("*", Nothing),("compress", Just 0.5)])+    map (\(str, result) -> either (Left . show) Right (parse encodings "" str) @?= (Right result)) acceptEncodings+    where+      acceptEncodings =+       [ (" gzip;q=1,*, compress ; q = 0.5 ", [("gzip", Just 1),("*", Nothing),("compress", Just 0.5)])+       , (" compress , gzip", [ ("compress", Nothing), ("gzip", Nothing)])+       , (" ", [])+       , (" *", [("*", Nothing)])+       , (" compress;q=0.5, gzip;q=1.0", [("compress", Just 0.5), ("gzip", Just 1.0)])+       , (" gzip;q=1.0, identity; q=0.5, *;q=0", [("gzip", Just 1.0), ("identity",Just 0.5), ("*", Just 0)])+       , (" x-gzip",[("x-gzip", Nothing)])+       ]++multipart :: Test+multipart =+    "split multipart" ~:+    [ ([BodyPart (pack "content-type: text/plain\r\n") (pack "1")], Nothing) @=?+           parseMultipartBody (pack "boundary")+                      (pack "--boundary\r\ncontent-type: text/plain\r\n\r\n1\r\n--boundary--\r\nend")++    , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1")], Nothing) @=?+           parseMultipartBody (pack "boundary.with.dot")+                      (pack "--boundary.with.dot\r\ncontent-type: text/plain\r\n\r\n1\r\n--boundary.with.dot--\r\nend")++    , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1")], Nothing) @=?+           parseMultipartBody (pack "boundary")+                      (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\r\n--boundary--\r\nend")++    , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1\n")], Nothing) @=?+           parseMultipartBody (pack "boundary")+                      (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\n\r\n--boundary--\r\nend")++    , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1\r\n")], Nothing) @=?+           parseMultipartBody (pack "boundary")+                      (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\r\n\r\n--boundary--\r\nend")+    , ([BodyPart (pack "content-type: text/plain\r\n") (pack "1\n\r")], Nothing) @=?+           parseMultipartBody (pack "boundary")+                      (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n1\n\r\r\n--boundary--\r\nend")++    , ([BodyPart (pack "content-type: text/plain\r\n") (pack "\r\n1\n\r")], Nothing) @=?+           parseMultipartBody (pack "boundary")+                      (pack "beg\r\n--boundary\r\ncontent-type: text/plain\r\n\r\n\r\n1\n\r\r\n--boundary--\r\nend")     ]++compressFilterResponseTest :: Test+compressFilterResponseTest =+    "compressFilterResponseTest" ~:+     [ uncompressedResponse+     , uncompressedSendFile+     , compressedResponseGZ+     , compressedResponseZ+     , compressedSendFile+     , compressedSendFileNoIdentity+     ]++mkRequest :: Method -> String -> [(String, Cookie)] -> Headers -> L.ByteString -> IO Request+mkRequest method uri cookies headers body =+    do let u = toSURI uri+       ib <- newEmptyMVar+       b  <- newMVar (Body body)+       return $ Request { rqMethod      = method+                        , rqPaths       = (pathEls (path u))+                        , rqUri         = (path u)+                        , rqQuery       = (query u)+                        , rqInputsQuery = (queryInput u)+                        , rqInputsBody  = ib+                        , rqCookies     = cookies+                        , rqVersion     = HttpVersion 1 1+                        , rqHeaders     = headers+                        , rqBody        = b+                        , rqPeer        = ("",0)+                        , rqSecure      = False+                        }++compressPart :: ServerPart Response+compressPart =+    do void compressedResponseFilter+       composeFilter noContentLength+       msum [ dir "response" $ ok (toResponse "compress Response")+            , dir "sendfile" $ ok (sendFileResponse "text/plain" "/dev/null" Nothing 0 100)+            ]++cookieHeaderOrderTestHandler :: ServerPart Response+cookieHeaderOrderTestHandler = do+  expireCookie "thecookie"+  addCookie Session $ mkCookie "thecookie" "value"+  ok $ toResponse $ "works"++cookieHeaderOrderTest :: Test+cookieHeaderOrderTest =+  "cookie header order test" ~:+    do req <- mkRequest GET "/" [] Map.empty L.empty+       res <- simpleHTTP'' cookieHeaderOrderTestHandler req+       let Just pair = (Map.lookup (B.pack "set-cookie") (rsHeaders res))+       assertEqual "Add cookie wins" False $ B.isInfixOf (B.pack "Max-Age=0")+                                                         (last $ hValue pair)++uncompressedResponse :: Test+uncompressedResponse =+    "uncompressedResponse" ~:+      do req <- mkRequest GET "/response" [] Map.empty L.empty+         res <- simpleHTTP'' compressPart req+         assertEqual "respone code"     (rsCode res) 200+         assertEqual "body"             (unpack (rsBody res)) "compress Response"+         assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing++uncompressedSendFile :: Test+uncompressedSendFile =+    "uncompressedSendFile" ~:+      do req <- mkRequest GET "/sendfile" [] Map.empty L.empty+         res <- simpleHTTP'' compressPart req+         assertEqual "respone code"     (rsCode res) 200+         assertEqual "filepath"         (sfFilePath res) "/dev/null"+         assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing++compressedResponseGZ :: Test+compressedResponseGZ =+    "compressedResponseGZ" ~:+      do req <- mkRequest GET "/response" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1"])) L.empty+         res <- simpleHTTP'' compressPart req+         assertEqual "respone code"     (rsCode res) 200+         assertEqual "body"             (unpack (GZ.decompress (rsBody res))) ("compress Response")+         assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) (Just (B.pack "Content-Encoding", [B.pack "gzip"]))++compressedResponseZ :: Test+compressedResponseZ =+    "compressedResponseZ" ~:+      do req <- mkRequest GET "/response" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " deflate;q=1"])) L.empty+         res <- simpleHTTP'' compressPart req+         assertEqual "respone code"     (rsCode res) 200+         assertEqual "body"             (unpack (Z.decompress (rsBody res))) ("compress Response")+         assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) (Just (B.pack "Content-Encoding", [B.pack "deflate"]))++compressedSendFile :: Test+compressedSendFile =+    "compressedSendfile" ~:+      do req <- mkRequest GET "/sendfile" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1"])) L.empty+         res <- simpleHTTP'' compressPart req+         assertEqual "respone code"     (rsCode res) 200+         assertEqual "filepath"         (sfFilePath res) "/dev/null"+         assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing++compressedSendFileNoIdentity :: Test+compressedSendFileNoIdentity =+    "compressedSendFileNoIdentity" ~:+      do req <- mkRequest GET "/sendfile" [] (Map.singleton (B.pack "accept-encoding") (HeaderPair (B.pack "Accept-Encoding") [B.pack " gzip;q=1, identity: q=0.0"])) L.empty+         res <- simpleHTTP'' compressPart req+         assertEqual "respone code"     (rsCode res) 406+         assertEqual "body"             (unpack (rsBody res)) ""+         assertEqual "Content-Encoding" ((hName &&& hValue) <$> Map.lookup (B.pack "content-encoding") (rsHeaders res)) Nothing++matchMethodTest :: Test+matchMethodTest =+    "matchMethodTest" ~:+      do forM_ gethead $ \m -> matchMethod GET m @?= True+         forM_ others  $ \m -> matchMethod GET m @?= False+         forM_ gethead $ \m -> matchMethod [GET] m @?= True+         forM_ others  $ \m -> matchMethod [GET] m @?= False+         forM_ gethead $ \m -> matchMethod [GET, HEAD] m @?= True+         forM_ others  $ \m -> matchMethod [GET, HEAD] m @?= False+         matchMethod POST GET   @?= False+         matchMethod POST HEAD  @?= False+         matchMethod POST TRACE @?= False+         matchMethod POST POST  @?= True+         matchMethod [POST, PUT] GET   @?= False+         matchMethod [POST, PUT] HEAD  @?= False+         matchMethod [POST, PUT] TRACE @?= False+         matchMethod [POST, PUT] POST  @?= True+         matchMethod [POST, PUT] PUT   @?= True+         forM_ (others) $ \m -> matchMethod (`notElem` gethead) m @?= True+         forM_ (gethead ++ others) $ \m -> matchMethod () m @?= True+  where+    gethead = [GET, HEAD]+    others  = [POST, PUT, DELETE, TRACE, OPTIONS, CONNECT]+++-- | https://github.com/Happstack/happstack-server/pull/56+pContentDispositionFilename :: Test+pContentDispositionFilename =+  "pContentDispositionFilename" ~:+    do let doesNotWorkWithOldParserButWithNew = "form-data; filename=\"file.pdf\"; name=\"file\"" :: String+       c <- parseContentDisposition doesNotWorkWithOldParserButWithNew+       assertEqual "parseContentDisposition" c (ContentDisposition "form-data" [("filename","file.pdf"),("name","file")])++applicativeTest :: Test+applicativeTest =+  "applicativeTest" ~:+    do req <- mkRequest GET "/response" [] mempty L.empty+       res <- flip simpleHTTP'' req $ do+         Left errors <- getDataFn $ (++) <$> look "a" <*> look "b"+         pure $ intercalate "," errors+       let ref = "Parameter not found: a,Parameter not found: b"+       assertEqual "getDataFn/ReaderError doesn't short-circuit" ref (unpack (rsBody res))
tests/Test.hs view
@@ -16,4 +16,4 @@                           return c        case (failures c) + (errors c) of          0 -> return ()-         n -> exitFailure+         _ -> exitFailure