happstack-server 0.2.1 → 0.3.1

raw patch · 11 files changed

+414/−254 lines, 11 filesdep +utf8-stringdep ~happstack-datadep ~happstack-utilPVP ok

version bump matches the API change (PVP)

Dependencies added: utf8-string

Dependency ranges changed: happstack-data, happstack-util

API changes (from Hackage documentation)

Files

• happstack-server.cabal +10/−5
• src/Happstack/Server/HTTP/Client.hs +2/−0
• src/Happstack/Server/HTTP/Clock.hs +1/−1
• src/Happstack/Server/HTTP/FileServe.hs +130/−32
• src/Happstack/Server/HTTP/Handler.hs +18/−7
• src/Happstack/Server/HTTP/Socket.hs +1/−1
• src/Happstack/Server/JSON.hs +0/−29
• src/Happstack/Server/MessageWrap.hs +3/−3
• src/Happstack/Server/Parts.hs +24/−14
• src/Happstack/Server/SURI.hs +1/−1
• src/Happstack/Server/SimpleHTTP.hs +224/−161

@@ -1,5 +1,5 @@ Name:                happstack-server-Version:             0.2.1+Version:             0.3.1 Synopsis:            Web related tools and services. Description:         Web framework License:             BSD3@@ -9,8 +9,13 @@ homepage:            http://happstack.com Category:            Web, Distributed Computing Build-Type:          Simple-Cabal-Version:       >= 1.4+Cabal-Version:       >= 1.6 +source-repository head+    type:     darcs+    subdir:   happstack-server+    location: http://patch-tag.com/publicrepos/happstack+ Flag base4     Description: Choose the even newer, even smaller, split-up base package. @@ -28,7 +33,6 @@                        Happstack.Server.HTTP.LowLevel                        Happstack.Server.HTTP.FileServe                        Happstack.Server.SimpleHTTP-                       Happstack.Server.JSON                        Happstack.Server.MessageWrap                        Happstack.Server.MinHaXML                        Happstack.Server.SURI@@ -61,8 +65,8 @@                        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,+                       happstack-data >= 0.3.1 && < 0.4,+                       happstack-util >= 0.3.1 && < 0.4,                        html,                        MaybeT,                        mtl,@@ -73,6 +77,7 @@                        process,                        template-haskell,                        time,+                       utf8-string >= 0.3.4 && < 0.4,                        xhtml,                        zlib 

@@ -10,6 +10,8 @@ import qualified Data.ByteString.Char8 as B  import Network +-- | Sends the serialized request to the host defined in the request+-- and attempts to parse response upon arrival. getResponse :: Request -> IO (Either String Response) getResponse rq = withSocketsDo $ do   let (hostName,p) = span (/=':') $ fromJust $ fmap B.unpack $ getHeader "host" rq 

@@ -22,7 +22,7 @@   return ref  updater :: IORef B.ByteString -> IO ()-updater ref = do threadDelay (10^(6 :: Int) * 1) -- Every second+updater ref = do threadDelay (10^(6 :: Int)) -- Every second                  writeIORef ref =<< mkTime                  updater ref 

@@ -1,7 +1,15 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, Rank2Types #-} module Happstack.Server.HTTP.FileServe     (-     MimeMap,fileServe, mimeTypes,isDot, blockDotFiles,doIndex,errorwrapper+     MimeMap,+     blockDotFiles,+     doIndex,+     doIndexStrict,+     errorwrapper,+     fileServe,+     fileServeStrict,+     isDot,+     mimeTypes     ) where  import Control.Exception.Extensible@@ -34,37 +42,102 @@                 do bintime <- getModificationTime binarylocation                    logtime <- getModificationTime loglocation                    if (logtime > bintime)-                     then fmap Just $ readFile loglocation -- fileServe [loglocation] [] "./"+                     then fmap Just $ readFile loglocation                      else return Nothing + type MimeMap = Map.Map String String +type GetFileFunc = (MonadIO m) =>+    Map.Map String String+    -> String+    -> m (Either String ((ClockTime, Integer), (String, L.ByteString)))+++ 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 =+doIndex = doIndex' getFile++-- | A variant of 'doIndex' that relies on 'getFileStrict'+doIndexStrict :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>+                 [String] -> MimeMap -> String -> m Response+doIndexStrict = doIndex' getFileStrict+++doIndex' :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>+            GetFileFunc+         -> [String]+         -> MimeMap+         -> String+         -> m Response+doIndex' _getFileFunc []           _mime _fp = forbidden $ toResponse "Directory index forbidden"+doIndex'  getFileFunc (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+    where retFile = returnFile getFileFunc 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 a file (lazy version). For efficiency reasons when serving large+-- files, will escape the computation early if a file is successfully served,+-- to prevent filters from being applied; if a filter were applied, we would+-- need to compute the content-length (thereby forcing the spine of the+-- ByteString into memory) rather than reading it from the filesystem.+--+-- Note that using lazy fileServe can result in some filehandles staying open+-- until the garbage collector gets around to closing them.+fileServe :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m) =>+             [FilePath]         -- ^ index files if the path is a directory+          -> FilePath           -- ^ file/directory to serve+          -> m Response+fileServe ixFiles localpath = do+    resp <- fileServe' localpath+                       (doIndex (ixFiles++defaultIxFiles))+                       mimeTypes+                       getFile +    escape' $ resp { rsFlags = RsFlags {rsfContentLength=False} }++++-- | Serve a file (strict version). Reads the entire file strictly into+-- memory, and ensures that the handle is properly closed. Unlike lazy+-- fileServe, this function doesn't shortcut the computation early, and it+-- allows for filtering (ex: gzip compression) to be applied+fileServeStrict :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>+                   [FilePath]   -- ^ index files if the path is a directory+                -> FilePath     -- ^ file/directory to serve+                -> m Response+fileServeStrict ixFiles localpath = do+    resp <- fileServe' localpath+                       (doIndex (ixFiles++defaultIxFiles))+                       mimeTypes+                       getFileStrict++    -- clear "Content-Length" because it could be modified by filters+    -- downstream+    let headers = rsHeaders resp+    return $ resp {rsHeaders = Map.delete (P.pack "content-length") headers}+++ -- | 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+              -> GetFileFunc               -> m Response-fileServe' localpath fdir mime = do+fileServe' localpath fdir mime getFileFunc = do     rq <- askRq     let fp2 = takeWhile (/=',') fp         fp = filepath@@ -84,20 +157,22 @@                | 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)+    getFileFunc 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)+              GetFileFunc -> Map.Map String String -> String -> m Response+returnFile getFileFunc mime fp =+    getFileFunc 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")   +ltrim = dropWhile (flip elem " \t\r")  returnGroup :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>                String -> Map.Map String String -> [String] -> m Response@@ -110,7 +185,7 @@   mbFiles <-  mapM (getFile mime) $ fps   let notFounds = [x | Left x <- mbFiles]       files = [x | Right x <- mbFiles]-  if not $ null notFounds +  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@@ -121,8 +196,9 @@   fileNotFound :: (Monad m, FilterMonad Response m) => String -> m Response-fileNotFound fp = do setResponseCode 404 -                     return $ toResponse $ "File not found "++ fp+fileNotFound fp = return $ result 404 $ "File not found " ++ fp++ --fakeLen = 71* 1024 fakeFile :: (Integral a) =>             a -> ((ClockTime, Int64), (String, L.ByteString))@@ -131,6 +207,9 @@       body = L.pack $ (("//"++(show len)++" ") ++ ) $ (replicate len '0') ++ "\n"       len = fromIntegral fakeLen +-- | @getFile mimeMap path@ will lazily read the file as a ByteString+-- with a content type provided by matching the file extension with the+-- @mimeMap@.  getFile will return an error string or ((timeFetched,size), (contentType,fileContents)) getFile :: (MonadIO m) =>            Map.Map String String            -> String@@ -139,13 +218,31 @@   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++  time <- liftIO $ getModificationTime fp+  h    <- liftIO $ openBinaryFile fp ReadMode   size <- liftIO $ hFileSize h-  lbs <- liftIO $ L.hGetContents h+  lbs  <- liftIO $ L.hGetContents h   return $ Right ((time,size),(ct,lbs)) +-- | As 'getFile' but strictly fetches the file, instead of lazily.+getFileStrict :: (MonadIO m) =>+                 Map.Map String String+              -> String+              -> m (Either String ((ClockTime, Integer), (String, L.ByteString)))+getFileStrict 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+  s        <- liftIO $ P.readFile fp+  let lbs  = L.fromChunks [s]+  let size = toInteger . P.length $ s+  return $ Right ((time,size),(ct,lbs))++ renderResponse :: (Monad m,                    ServerMonad m,                    FilterMonad Response m,@@ -156,21 +253,21 @@ renderResponse _ ((modtime,size),(ct,body)) = do   rq <- askRq   let notmodified = getHeader "if-modified-since" rq == Just (P.pack $ repr)-      repr = formatCalendarTime defaultTimeLocale +      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+  if notmodified then+      return $ result 304 ""+    else do+      return $ ((setHeader "Last-modified" repr) .+                (setHeader "Content-Length" (show size)) .+                (setHeader "Content-Type" ct)) $+               resultBS 200 body -                + getExt :: String -> String getExt = reverse . takeWhile (/='.') . reverse @@ -181,6 +278,7 @@ 	    ,("xsl","application/xml") 	    ,("js","text/javascript") 	    ,("html","text/html")+	    ,("htm","text/html") 	    ,("css","text/css") 	    ,("gif","image/gif") 	    ,("jpg","image/jpeg")

@@ -35,8 +35,6 @@ 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 @@ -84,16 +82,29 @@                      time <- getCurrentTime                      let host' = fst host                          user = "-"-                         requestLine = unwords [show $ rqMethod req, rqUri req, show $ rqVersion req]+                         requestLn = unwords [show $ rqMethod req, rqUri req, show $ rqVersion req]                          responseCode = rsCode res-                         size = toInteger $ L.length $ rsBody res+                         sendContentLength = rsfContentLength (rsFlags res)++                         -- don't force the bytestring if "sendContentLength"+                         -- is false, at least not if a content-length header+                         -- has been set+                         size = if not sendContentLength then+                                    maybe (toInteger $ L.length $ rsBody res)+                                          ((read . P.unpack) :: P.ByteString -> Integer)+                                          (getHeaderBS contentLengthC req)+                                  else+                                    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-                     +                     logM "Happstack.Server.AccessLog.Combined" INFO $ formatRequestCombined host' user time requestLn responseCode size referer userAgent+                      putAugmentedResult h req res                      when (continueHTTP req res) $ rloop conf h host handler rest +-- | Unserializes the bytestring into a response.  If there is an+-- error it will return @Left msg@. parseResponse :: L.ByteString -> Either String Response parseResponse inputStr =     do (topStr,restStr) <- required "failed to separate response" $ @@ -205,7 +216,7 @@   when (rqMethod req /= HEAD) $ L.hPut h $ rsBody res   hFlush h -+-- | Serializes the request to the given handle putRequest :: Handle -> Request -> IO () putRequest h rq = do      let put = B.hPut h

@@ -18,7 +18,7 @@   ) import System.IO --- alternative implementation of accept to work around EAI_AGAIN errors+-- | 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

@@ -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

@@ -13,7 +13,7 @@ import Happstack.Util.Common  queryInput :: SURI -> [(String, Input)]-queryInput uri = formDecode (case SURI.query $ uri of+queryInput uri = formDecode (case SURI.query uri of                                '?':r -> r                                xs    -> xs) @@ -25,7 +25,7 @@     in decodeBody ctype (getBS $ rqBody req)  --- Decodes application\/x-www-form-urlencoded inputs.      +-- | Decodes application\/x-www-form-urlencoded inputs.       formDecode :: String -> [(String, Input)] formDecode [] = [] formDecode qString = @@ -71,7 +71,7 @@               _ -> ("ERROR",simpleInput "ERROR") -- FIXME: report error     where ctype = fromMaybe defaultInputType (getContentType hs) -+-- | Packs a string into an Input of type "text/plain" simpleInput :: String -> Input simpleInput v     = Input { inputValue = L.pack v

@@ -8,6 +8,7 @@ import Happstack.Server.SimpleHTTP import Text.ParserCombinators.Parsec import Control.Monad+import Data.Char import Data.Maybe import Data.List import qualified Data.ByteString.Char8 as BS@@ -22,19 +23,27 @@     (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+    getHeaderM "Accept-Encoding" >>=+        (maybe (return "identity") installHandler)++  where+    badEncoding = "Encoding returned not in the list of known encodings"++    installHandler accept = do+      let eEncoding = bestEncoding $ BS.unpack accept+      (coding,action) <- case eEncoding of+          Left _ -> do             setResponseCode 406             finishWith $ toResponse ""-        Right a -> return (a, maybe (fail "Encoding returned not in the list of known encodings")-            id (lookup a allEncodingHandlers))-    setHeaderM "Content-Encoding" coding-    action-    return coding +          Right a -> return (a, fromMaybe (fail badEncoding)+                                          (lookup a allEncodingHandlers))++      setHeaderM "Content-Encoding" coding+      action+      return coding++ -- | compresses the body of the response with gzip. -- does not set any headers. gzipFilter::(FilterMonad Response m) => m()@@ -113,7 +122,7 @@ --    ,compressFilter     ,deflateFilter     ,return ()-    ,fail $ "chose * as content encoding"+    ,fail "chose * as content encoding"     ]  -- | unsupported:  a parser for the Accept-Encoding header@@ -125,16 +134,17 @@             ws             char ','             ws+                 encoding1 :: GenParser Char st ([Char], Maybe Double)         encoding1 = do-            encoding <- many1 letter <|> string "*"+            encoding <- many1 alphaNum <|> string "*"             ws             quality<-optionMaybe qual             return (encoding, fmap read quality)         qual = do             char ';' >> ws >> char 'q' >> ws >> char '=' >> ws             q<-float-            return $ q+            return q         int = many1 digit         float = do                 wholePart<-many1 digit@@ -143,7 +153,7 @@             <|>                 do                 fractionalPart<-fraction-                return $ fractionalPart+                return fractionalPart         fraction :: GenParser Char st String         fraction = do             char '.'

@@ -38,9 +38,9 @@ unEscape = URI.unEscapeString . map (\x->if x=='+' then ' ' else x) 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) instance Show SURI where

@@ -1,6 +1,16 @@-{-# LANGUAGE UndecidableInstances, OverlappingInstances, ScopedTypeVariables, FlexibleInstances, TypeSynonymInstances,-    MultiParamTypeClasses, PatternGuards, FlexibleContexts, FunctionalDependencies, GeneralizedNewtypeDeriving, PatternSignatures-    #-}++{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSignatures #-}+ {-# OPTIONS -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- |@@ -16,7 +26,7 @@ -- -- 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,@@ -39,12 +49,12 @@ -- 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.@@ -63,7 +73,7 @@ --        authHeader <- getHeaderM \"authorization\" --        case authHeader of --            Nothing -> err---            Just x  -> case parseHeader x of +--            Just x  -> case parseHeader x of --                (name, \':\':pass) | validLogin name pass -> mzero --                                   | otherwise -> err --                _                                       -> err@@ -87,7 +97,7 @@ --     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. --@@ -109,6 +119,7 @@     , anyRequest     -- * WebT     , WebT(..)+    , UnWebT     , FilterFun     , Web     , mkWebT@@ -140,7 +151,7 @@     , badGateway     , internalServerError     , badRequest-    , unauthorized +    , unauthorized     , forbidden     , notFound     , seeOther@@ -203,46 +214,75 @@     , 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 () +import qualified Paths_happstack_server          as Cabal++import qualified Data.Version                    as DV+import Happstack.Server.HTTP.Client              (getResponse, unproxify, unrproxify)+import Happstack.Data.Xml.HaXml                  (toHaXmlEl)+import qualified Happstack.Server.MinHaXML       as H+import qualified Happstack.Server.HTTP.Listen    as Listen (listen) -- So that we can disambiguate 'Writer.listen'+import Happstack.Server.XSLT                     (XSLTCmd, XSLPath, procLBSIO)+import Happstack.Server.SURI                     (ToSURI)+import Happstack.Util.Common                     (Seconds, readM)+import Happstack.Data                            (Xml, normalize, fromPairs, Element, toXml, toPublicXml) -- used by default implementation of fromData+import Control.Applicative                       (Applicative, pure, (<*>))+import Control.Concurrent                        (forkIO)+import Control.Exception                         (evaluate)+import Control.Monad                             ( MonadPlus, mzero, mplus+                                                 , msum, ap, unless+                                                 , liftM, liftM2, liftM3, liftM4+                                                 )+import Control.Monad.Trans                       ( MonadTrans, lift+                                                 , MonadIO, liftIO+                                                 )+import Control.Monad.Reader                      ( ReaderT(ReaderT), runReaderT+                                                 , MonadReader, ask, local+                                                 , asks+                                                 )+import Control.Monad.Writer                      ( WriterT(WriterT), runWriterT+                                                 , MonadWriter, tell, pass+                                                 , listens+                                                 )+import qualified Control.Monad.Writer            as Writer (listen) -- So that we can disambiguate 'Listen.listen'+import Control.Monad.State                       (MonadState, get, put)+import Control.Monad.Error                       ( ErrorT(ErrorT), runErrorT+                                                 , Error, strMsg+                                                 , MonadError, throwError, catchError+                                                 )+import Control.Monad.Maybe                       (MaybeT(MaybeT), runMaybeT)+import Data.Char                                 (ord)+import Data.Maybe                                (fromMaybe)+import Data.Monoid                               ( Monoid, mempty, mappend+                                                 , Dual(Dual), getDual+                                                 , Endo(Endo), appEndo+                                                 )++import qualified Data.ByteString.Char8           as B+import qualified Data.ByteString.Lazy.Char8      as L+import qualified Data.ByteString.Lazy.UTF8       as LU (toString)++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                                 (toLower)+import Data.List                                 (isPrefixOf)+import System.IO                                 (hGetContents, hClose)+import System.Console.GetOpt                     ( OptDescr(Option)+                                                 , ArgDescr(ReqArg)+                                                 , ArgOrder(Permute)+                                                 , getOpt+                                                 )+import System.Process                            (runInteractiveProcess, waitForProcess)+import System.Exit                               (ExitCode(ExitSuccess, ExitFailure))+ -- | An alias for WebT when using IO type Web a = WebT IO a -- | An alias for using ServerPartT when using the IO@@ -279,44 +319,45 @@ -- 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:: (Monad m, Show e) => UnWebT (ErrorT e m) a -> UnWebT m a --   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 :: (     UnWebT m a ->      UnWebT n b)+               -> (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' :: (Request -> UnWebT m a ->      UnWebT n b)+                -> (      ServerPartT m a -> ServerPartT n b) mapServerPartT' f ma = withRequest $ \rq -> mapWebT (f rq) (runServerPartT ma rq)+ instance MonadTrans (ServerPartT) where     lift m = withRequest (\_ -> lift m) -instance (Monad m) => Monoid (ServerPartT m a)- where mempty = mzero-       mappend = mplus+instance (Monad m) => Monoid (ServerPartT m a) where+    mempty  = mzero+    mappend = mplus  instance (Monad m, Functor m) => Applicative (ServerPartT m) where     pure = return@@ -351,48 +392,58 @@ -- 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+    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)+--   Set    x `mappend` Append y = Set    (x `mappend` y) --   Append x `mappend` Append y = Append (x `mappend` y)---   \_     `mappend` Set y = Set 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+-- A simple way of sumerizing this is, if the right side is Append, then the+-- right is appended to the left.  If the right 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)++   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+-- | 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 (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 }+unFilterFun :: FilterFun a -> (a -> a)+unFilterFun = appEndo . getDual . extract++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@@ -420,23 +471,27 @@     -- existing filter function.     composeFilter :: (a->a) -> m ()     -- | retrives the filter from the environment-    getFilter :: m b -> m (b,a->a)+    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) +    setFilter     = FilterT . tell                . Set    . Dual . Endo+    composeFilter = FilterT . tell                . Append . Dual . Endo+    getFilter     = FilterT . listens unFilterFun . unFilterT  -- | The basic response building object.+newtype WebT m a = WebT { unWebT :: ErrorT Response (FilterT (Response) (MaybeT m)) a }+    deriving (MonadIO, Functor)++-- | --  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,@@ -475,9 +530,8 @@ --          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)+--+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@@ -525,39 +579,36 @@ 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)+    getFilter     m = WebT $ ErrorT $ fmap lft $ getFilter (runErrorT $ unWebT m)+        where+          lft (Left  r, _) = Left r+          lft (Right a, f) = Right (a, f)  instance (Monad m) => Monoid (WebT m a) where     mempty = mzero     mappend = mplus --- | 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+-- | 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+ -- | 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 :: WebT m a -> UnWebT m a 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 :: UnWebT m a -> 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)-+mapWebT :: (UnWebT m a -> UnWebT n b)+        -> (  WebT m a ->   WebT n b)+mapWebT f ma = mkWebT $ f (ununWebT ma)  instance (Monad m, Functor m) => Applicative (WebT m) where     pure = return@@ -576,7 +627,7 @@  	catchError action handler = mkWebT $ catchError (ununWebT action) (ununWebT . handler)  instance MonadWriter w m => MonadWriter w (WebT m) where-    tell = lift . Writer.tell+    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)@@ -627,36 +678,39 @@  -- | 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+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 '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'' :: (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  --- | a wrapper for Read apparently.  Pretty much only used for 'path' and probably--- unnecessarily, as it is exactly "readM"+-- | This class is used by 'path' to parse a path component into a value.+-- At present, the instances for number types (Int, Float, etc) just+-- call 'readM'. The instance for 'String' however, just passes the+-- path component straight through. This is so that you can read a+-- path component which looks like this as a String:+--+--  \/somestring\/+--+-- instead of requiring the path component to look like:+--+-- \/"somestring"\/ 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+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 @@ -739,9 +793,9 @@   class MatchMethod m where matchMethod :: m -> Method -> Bool-instance MatchMethod Method where matchMethod m = (== m) +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 (Method -> Bool) where matchMethod f = f instance MatchMethod () where matchMethod () _ = True  -- | flatten turns your arbitrary @m a@ and converts it too@@ -768,7 +822,7 @@ 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 +-- 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@@ -779,7 +833,7 @@ guardRq :: (ServerMonad m, MonadPlus m) => (Request -> Bool) -> m () guardRq f = do     rq <- askRq-    when ( f rq /= True ) mzero +    unless (f rq) mzero  -- | Guard against the method.  This function also guards against -- any remaining path segments.  See methodOnly for the version@@ -814,19 +868,15 @@         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.+-- | 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)-               | otherwise -> mzero         _ -> mzero  -- | grabs the rest of the URL (dirs + query) and passes it to your handler@@ -892,11 +942,7 @@ -- | 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+withDataFn fn handle = getDataFn fn >>= maybe mzero handle  -- | proxyServe is for creating ServerPartT's that proxy. -- The sole argument [String] is a list of allowed domains for@@ -923,7 +969,7 @@      | superdomain `elem` wildcards =True      | otherwise = False      where-     domain = head (rqPaths rq) +     domain = head (rqPaths rq)      superdomain = tail $ snd $ break (=='.') domain      wildcards = (map (drop 2) $ filter ("*." `isPrefixOf`) allowed) @@ -980,9 +1026,9 @@  doXslt :: (MonadIO m) =>           XSLTCmd -> XSLPath -> Response -> m Response-doXslt cmd xslPath res = +doXslt cmd xslPath res =     do new <- liftIO $ procLBSIO cmd xslPath $ rsBody res-       return $ setHeader "Content-Type" "text/html" $ +       return $ setHeader "Content-Type" "text/html" $               setHeader "Content-Length" (show $ L.length new) $               res { rsBody = new } @@ -1012,9 +1058,11 @@ ok :: (FilterMonad Response m) => a -> m a ok = resp 200 +-- | Respond with @500 Interal Server Error@ internalServerError :: (FilterMonad Response m) => a -> m a internalServerError = resp 500 +-- | Responds with @502 Bad Gateway@ badGateway :: (FilterMonad Response m) => a -> m a badGateway = resp 502 @@ -1072,7 +1120,7 @@ anyRequest x = withRequest $ \_ -> x  -- | again, why is this useful?-applyRequest :: (ToMessage a, Monad m) =>+applyRequest :: (ToMessage a, Monad m, Functor m) =>                 ServerPartT m a -> Request -> Either (m Response) b applyRequest hs = simpleHTTP'' hs >>= return . Left @@ -1120,7 +1168,7 @@  -- | Gets the named input as a String look :: String -> RqData String-look = fmap L.unpack . lookBS+look = fmap LU.toString . lookBS  -- | Gets the named cookie -- the cookie name is case insensitive@@ -1145,7 +1193,7 @@  -- | 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))+lookPairs = asks fst >>= return . map (\(n,vbs)->(n,LU.toString $ inputValue vbs))   --------------------------------------------------------------@@ -1157,7 +1205,7 @@ -- --   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 :: (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@@ -1179,18 +1227,17 @@ -- 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:: Monad m => (e -> ServerPartT m a)+              -> Request+              -> UnWebT (ErrorT e m) a+              -> UnWebT m a spUnwrapErrorT handler rq = \x -> do     err <- runErrorT x     case err of@@ -1245,9 +1292,9 @@ 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. +-- use the supplied default instead. -- -- Note: This function will run validation unconditionally. You -- probably want 'setValidator' or 'validateConf'.@@ -1278,7 +1325,7 @@ 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@@ -1290,7 +1337,7 @@ -- -- 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@@ -1311,14 +1358,14 @@            ec <- waitForProcess ph            case ec of              ExitSuccess     -> return response-             (ExitFailure _) -> +             (ExitFailure _) ->                  return $ toResponse (unlines ([ "ExitCode: " ++ show ec                                                , "stdout:"                                                , out                                                , "stderr:"                                                , err                                                , "input:"-                                               ] ++ +                                               ] ++                                                showLines (rsBody response)))     | otherwise = return response     where@@ -1335,21 +1382,37 @@     finishWith $ res  failHtml:: String->String-failHtml errString = "<html><head><title>Happstack "-    ++ ver ++ " Internal Server Error</title>"+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 />"+    ++ "<p>Something went wrong here<br>"+    ++ "Internal server error<br>"     ++ "Everything has stopped</p>"-    ++ "<p>The error was \"" ++ errString ++ "\"</p></body></html>"+    ++ "<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]+ notFoundHtml :: String-notFoundHtml = "<html><head><title>Happstack "-    ++ ver ++ " File not found</title>"+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 />"+    ++ "<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