happstack-server 6.3.1 → 6.4.1

raw patch · 19 files changed

+285/−77 lines, 19 filesdep +base64-bytestringdep −happstack-utilPVP ok

version bump matches the API change (PVP)

Dependencies added: base64-bytestring

Dependencies removed: happstack-util

API changes (from Hackage documentation)

Files

• happstack-server.cabal +3/−3
• src/Happstack/Server/Auth.hs +15/−8
• src/Happstack/Server/Client.hs +2/−2
• src/Happstack/Server/Cookie.hs +0/−1
• src/Happstack/Server/HTTPClient/HTTP.hs +4/−3
• src/Happstack/Server/Internal/Compression.hs +1/−1
• src/Happstack/Server/Internal/Cookie.hs +3/−4
• src/Happstack/Server/Internal/Handler.hs +1/−1
• src/Happstack/Server/Internal/LogFormat.hs +57/−0
• src/Happstack/Server/Internal/MessageWrap.hs +18/−10
• src/Happstack/Server/Internal/Socket.hs +28/−1
• src/Happstack/Server/Internal/Types.hs +64/−3
• src/Happstack/Server/Routing.hs +1/−27
• src/Happstack/Server/RqData.hs +30/−7
• src/Happstack/Server/SURI.hs +5/−1
• src/Happstack/Server/SURI/ParseURI.hs +21/−1
• src/Happstack/Server/SimpleHTTP.hs +2/−2
• src/Happstack/Server/Types.hs +2/−1
• src/Happstack/Server/XSLT.hs +28/−1

@@ -1,5 +1,5 @@ Name:                happstack-server-Version:             6.3.1+Version:             6.4.1 Synopsis:            Web related tools and services. Description:         Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course <http://happstack.com/docs/crashcourse/index.html> License:             BSD3@@ -69,6 +69,7 @@                        Happstack.Server.Internal.Handler                        Happstack.Server.Internal.LazyLiner                        Happstack.Server.Internal.Listen+                       Happstack.Server.Internal.LogFormat                        Happstack.Server.Internal.Multipart                        Happstack.Server.Internal.RFC822Headers                        Happstack.Server.Internal.Socket@@ -78,15 +79,14 @@    Build-Depends:       base,                        blaze-html >= 0.3 && < 0.5,+                       base64-bytestring == 0.1.*,                        bytestring,                        containers,                        directory,                        extensible-exceptions,                        filepath,---                       HaXml >= 1.13 && < 1.14,                        hslogger >= 1.0.2,                        happstack-data >= 6.0 && < 6.1,-                       happstack-util >= 6.0 && < 6.1,                        html,                        MaybeT,                        mtl >= 1.1 && < 2.1,

@@ -3,10 +3,11 @@ module Happstack.Server.Auth where  import Control.Monad                             (MonadPlus(mzero, mplus))+import Data.ByteString.Base64                    as Base64 import qualified Data.ByteString.Char8           as B+import Data.Char                                 (chr) import qualified Data.Map                        as M-import qualified Happstack.Crypto.Base64         as Base64-import Happstack.Server.Monads                   (FilterMonad, ServerMonad, WebMonad, escape, getHeaderM, setHeaderM)+import Happstack.Server.Monads                   (Happstack, FilterMonad, ServerMonad, WebMonad, escape, getHeaderM, setHeaderM) import Happstack.Server.Types                    (Response) import Happstack.Server.Response                 (unauthorized, toResponse) @@ -21,7 +22,7 @@ -- >       , ok "You are not in the secret club."  -- >       ] -- -basicAuth :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadPlus m) =>+basicAuth :: (Happstack m) =>    String -- ^ the realm name    -> M.Map String String -- ^ the username password map    -> m a -- ^ the part to guard@@ -32,14 +33,20 @@         aHeader <- getHeaderM "authorization"         case aHeader of             Nothing -> err-            Just x -> case parseHeader x of-                (name, ':':password) | validLogin name password -> mzero-                                     | otherwise -> err-                _  -> err+            Just x -> +                do r <- parseHeader x +                   case r of+                     (name, ':':password) | validLogin name password -> mzero+                                          | otherwise -> err+                     _  -> err     validLogin name password = M.lookup name authMap == Just password-    parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6+    parseHeader h = +      case Base64.decode . B.drop 6 $ h of+        (Left _)   -> err+        (Right bs) -> return (break (':'==) (B.unpack bs))     headerName  = "WWW-Authenticate"     headerValue = "Basic realm=\"" ++ realmName ++ "\""+    err :: (Happstack m) => m a     err = escape $ do             setHeaderM headerName headerValue             unauthorized $ toResponse "Not authorized"

@@ -2,7 +2,7 @@ module Happstack.Server.Client where  import Happstack.Server.Internal.Handler    (parseResponse, putRequest)-import Happstack.Server.Internal.Types      (Response, Request, getHeader)+import Happstack.Server.Internal.Types      (Response, Request, getHeader, readDec') import Data.Maybe                           (fromJust) import qualified Data.ByteString.Char8      as B import qualified Data.ByteString.Lazy.Char8 as L @@ -14,7 +14,7 @@ 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+      portInt = if null p then 80 else readDec' $ tail p       portId = PortNumber $ toEnum $ portInt   h <- connectTo hostName portId    hSetBuffering h NoBuffering

@@ -17,7 +17,6 @@ import Happstack.Server.Internal.Monads (FilterMonad, composeFilter) import Happstack.Server.Internal.Cookie (Cookie(..), CookieLife(..), calcLife, mkCookie, mkCookieHeader) import Happstack.Server.Types           (Response, addHeader)-import Happstack.Util.Common            (Seconds)  -- | Add the 'Cookie' to 'Response'. --

@@ -135,6 +135,7 @@ import Network.URI import Happstack.Server.HTTPClient.Stream import Happstack.Server.HTTPClient.TCP+import Happstack.Server.Internal.Types (readDec')   -- Util@@ -627,7 +628,7 @@     where         port auth = if null (uriPort auth)             then 80-            else read $ uriPort auth+            else readDec' $ uriPort auth               -- | Like 'simpleHTTP', but acting on an already opened stream.@@ -790,7 +791,7 @@                     do { rslt <- case tc of                           Nothing ->                                case cl of-                                  Just x  -> linearTransfer conn (read x :: Int)+                                  Just x  -> linearTransfer conn (readDec' x :: Int)                                   Nothing -> hopefulTransfer conn ""                           Just x  ->                                case map toLower (trim x) of@@ -838,7 +839,7 @@ 	       rslt <- case tc of                           Nothing ->                               case cl of-                                  Just x  -> linearTransfer conn (read x :: Int)+                                  Just x  -> linearTransfer conn (readDec' x :: Int)                                   Nothing -> return (Right ([], "")) -- hopefulTransfer ""                           Just x  ->                               case map toLower (trim x) of

@@ -177,7 +177,7 @@             encoding <- many1 (alphaNum <|> char '-') <|> string "*"             ws             quality<-optionMaybe qual-            return (encoding, fmap read quality)+            return (encoding, fmap readDec' quality)          qual :: GenParser Char st String         qual = do

@@ -24,7 +24,6 @@ import Data.Time.Clock       (UTCTime, addUTCTime, diffUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Time.Format      (formatTime)-import Happstack.Util.Common (Seconds) import Happstack.Server.Internal.Clock (getApproximateUTCTime) import Text.ParserCombinators.Parsec hiding (token) import System.Locale         (defaultTimeLocale)@@ -49,13 +48,13 @@ -- data CookieLife     = Session         -- ^ session cookie - expires when browser is closed-    | MaxAge Seconds  -- ^ life time of cookie in seconds+    | MaxAge Int      -- ^ life time of cookie in seconds     | Expires UTCTime -- ^ cookie expiration date     | Expired         -- ^ cookie already expired       deriving (Eq, Ord, Read, Show, Typeable)  -- convert 'CookieLife' to the argument needed for calling 'mkCookieHeader'-calcLife :: CookieLife -> IO (Maybe (Seconds, UTCTime))+calcLife :: CookieLife -> IO (Maybe (Int, UTCTime)) calcLife Session = return Nothing calcLife (MaxAge s) =           do now <- getApproximateUTCTime@@ -89,7 +88,7 @@ -- -- See 'CookieLife' and 'calcLife' for a convenient way of calculating -- the first argument to this function.-mkCookieHeader :: Maybe (Seconds, UTCTime) -> Cookie -> String+mkCookieHeader :: Maybe (Int, UTCTime) -> Cookie -> String mkCookieHeader mLife cookie =     let l = [("Domain=",  cookieDomain cookie)             ,("Max-Age=", maybe "" (show . max 0 . fst) mLife)

@@ -95,7 +95,7 @@                                   user         = "-"                                   requestLn    = unwords [show $ rqMethod req, rqUri req, show $ rqVersion req]                                   responseCode = rsCode res-                                  size         = maybe (-1) (read . B.unpack) (getHeader "Content-Length" res) -- -1 indicates unknown size+                                  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

@@ -0,0 +1,57 @@+module Happstack.Server.Internal.LogFormat+  ( formatTimeCombined+  , formatRequestCombined+  ) where++import System.Locale (defaultTimeLocale)+import Data.Time.Format (FormatTime(..), formatTime)++-- | 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

@@ -15,7 +15,6 @@ import Happstack.Server.Internal.Multipart import Happstack.Server.Internal.RFC822Headers (parseContentType) import Happstack.Server.SURI as SURI-import Happstack.Util.Common  queryInput :: SURI -> [(String, Input)] queryInput uri = formDecode (case SURI.query uri of@@ -117,13 +116,22 @@ 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 +-- | 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 -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 +-- | 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'+							

@@ -1,9 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} module Happstack.Server.Internal.Socket(acceptLite) where +import Data.List (intersperse)+import Data.Word (Word32) import Happstack.Server.Internal.SocketTH(supportsIPv6) import Language.Haskell.TH.Syntax-import Happstack.Util.HostAddress import qualified Network as N   ( PortID(PortNumber)   , socketPort@@ -16,7 +17,33 @@   , accept   , socketToHandle   )+import Numeric (showHex) import System.IO++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)

@@ -14,7 +14,8 @@      isHTTP1_0, isHTTP1_1,      RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength,      HttpVersion(..), Length(..), Method(..), Headers, continueHTTP,-     Host, ContentType(..)+     Host, ContentType(..),+     readDec', readM, FromReqURI(..)     ) where  @@ -30,14 +31,16 @@ 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   (Int, Int8, Int16, Int32, Int64) import Data.Maybe import Data.List+import Data.Word  (Word, Word8, Word16, Word32, Word64) import Happstack.Server.SURI import Data.Char (toLower)- import Happstack.Server.Internal.RFC822Headers ( ContentType(..) ) import Happstack.Server.Internal.Cookie-import Happstack.Util.LogFormat (formatRequestCombined)+import Happstack.Server.Internal.LogFormat (formatRequestCombined)+import Numeric (readDec) import System.Log.Logger (Priority(..), logM) import Text.Show.Functions () @@ -396,3 +399,61 @@ keepaliveC :: ByteString keepaliveC  = P.pack "Keep-Alive" +readDec' :: (Num a) => String -> a+readDec' s =+  case readDec s of+    [(n,[])] -> n+    _    -> error "readDec' failed."+    +-- | Read in any monad.+readM :: (Monad m, Read t) => String -> m t+readM s = case reads s of+            [(v,"")] -> return v+            _        -> fail "readM: parse error"+            +-- |convert a 'ReadS a' result to 'Maybe a'+fromReadS :: [(a, String)] -> Maybe a+fromReadS [(n,[])] = Just n+fromReadS _        = Nothing+    +-- | This class is used by 'path' to parse a path component into a+-- value.+-- +-- The instances for number types ('Int', 'Float', etc) use 'readM' to+-- parse the path component.+--+-- The instance for 'String', on the other hand, returns the+-- unmodified path component.+--+-- See the following section of the Happstack Crash Course for+-- detailed instructions using and extending 'FromReqURI':+--+--  <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 Char    where fromReqURI s = case s of [c] -> Just c ; _ -> Nothing+instance FromReqURI Int     where fromReqURI = fromReadS . readDec+instance FromReqURI Int8    where fromReqURI = fromReadS . readDec+instance FromReqURI Int16   where fromReqURI = fromReadS . readDec                                  +instance FromReqURI Int32   where fromReqURI = fromReadS . readDec                                  +instance FromReqURI Int64   where fromReqURI = fromReadS . readDec                                  +instance FromReqURI Integer where fromReqURI = fromReadS . 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

@@ -13,7 +13,6 @@     , nullDir     , trailingSlash     , anyPath-    , FromReqURI(..)     , path     , uriRest     -- * Route by host@@ -27,8 +26,7 @@ import qualified Data.ByteString.Char8            as B import           Happstack.Server.Monads          (ServerPartT, ServerMonad(..)) import           Happstack.Server.Internal.Monads (WebT, anyRequest)-import           Happstack.Server.Types           (Request(..), Method(..), getHeader, rqURL)-import           Happstack.Util.Common            (readM)+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.@@ -44,30 +42,6 @@ instance MatchMethod [Method] where matchMethod methods = (`elem` methods) instance MatchMethod (Method -> Bool) where matchMethod f = f instance MatchMethod () where matchMethod () _ = True---- | 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 Int     where fromReqURI = readM-instance FromReqURI Integer where fromReqURI = readM-instance FromReqURI Float   where fromReqURI = readM-instance FromReqURI Double  where fromReqURI = readM-  ------------------------------------- -- guards

@@ -73,7 +73,7 @@ import Happstack.Server.Cookie 			(Cookie (cookieValue)) import Happstack.Server.Internal.Monads         (ServerMonad(askRq, localRq), FilterMonad, WebMonad, ServerPartT, escape) import Happstack.Server.Internal.RFC822Headers  (parseContentType)-import Happstack.Server.Types                   (ContentType(..), Input(inputValue, inputFilename, inputContentType), Response, Request(rqInputsQuery, rqInputsBody, rqCookies, rqMethod), Method(POST,PUT), getHeader, readInputsBody)+import Happstack.Server.Types                   (ContentType(..), FromReqURI(..), Input(inputValue, inputFilename, inputContentType), Response, Request(rqInputsQuery, rqInputsBody, rqCookies, rqMethod), Method(POST,PUT), getHeader, readInputsBody) import Happstack.Server.Internal.MessageWrap    (BodyPolicy(..), bodyInput, defaultBodyPolicy) import Happstack.Server.Response                (internalServerError, requestEntityTooLarge, toResponse) @@ -187,18 +187,41 @@  -- | use 'read' to convert a 'String' to a value of type 'a' ----- > look "key" `checkRq` (readRq "key")+-- > look "key" `checkRq` (unsafeReadRq "key") --  -- use with 'checkRq'-readRq :: (Read a) => +--+-- 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-readRq key val =+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@@ -373,7 +396,7 @@ lookCookieValue = fmap cookieValue . lookCookie  -- | gets the named cookie as the requested Read type-readCookieValue :: (Functor m, Monad m, HasRqData m, Read a) => String -> m a+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'@@ -383,7 +406,7 @@ -- This function assumes the underlying octets are UTF-8 encoded. -- -- see also: 'lookReads'-lookRead :: (Functor m, Monad m, HasRqData m, Read a) => String -> m a+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'@@ -393,7 +416,7 @@ -- This function assumes the underlying octets are UTF-8 encoded. -- -- see also: 'lookReads'-lookReads :: (Functor m, Monad m, HasRqData m, Read a) => String -> m [a]+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

@@ -1,11 +1,12 @@ {-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-} -- | 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 where++import Control.Arrow (first) import Data.Maybe import Data.Generics import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText-import Happstack.Util.Common(mapFst) import qualified Network.URI as URI  -- | Retrieves the path component from the URI@@ -49,6 +50,9 @@     showsPrec d (SURI uri) = showsPrec d $ show uri instance Read SURI where     readsPrec d = mapFst fromJust .  filter (isJust . fst) . mapFst parse . readsPrec d +      where+        mapFst :: (a -> b) -> [(a,x)] -> [(b,x)]+        mapFst = map . first  instance Ord SURI where     compare a b = show a `compare` show b

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

@@ -87,7 +87,7 @@ import qualified Data.Version                    as DV import Happstack.Server.Internal.Monads          (FilterFun, WebT(..), UnWebT, unFilterFun, mapServerPartT, runServerPartT, ununWebT) import qualified Happstack.Server.Internal.Listen as Listen (listen, listen',listenOn, listenOnIPv4) -- So that we can disambiguate 'Writer.listen'-import Happstack.Server.Types                    (Conf(port, validator), Request, Response(rsBody, rsCode), nullConf, setHeader)+import Happstack.Server.Types                    (Conf(port, validator), Request, Response(rsBody, rsCode), nullConf, readDec', setHeader) import Network                                   (Socket) import qualified Paths_happstack_server          as Cabal import System.Console.GetOpt                     ( OptDescr(Option)@@ -105,7 +105,7 @@ -- | 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"]+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

@@ -12,7 +12,8 @@      isHTTP1_0, isHTTP1_1,      RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength,      HttpVersion(..), Length(..), Method(..), Headers, continueHTTP,-     Host, ContentType(..)+     Host, ContentType(..),+     readDec', FromReqURI(..)     ) where  import Happstack.Server.Internal.Types

@@ -12,6 +12,8 @@  import System.Log.Logger +import Control.Concurrent              (forkIO)+import Control.Concurrent.MVar         (newEmptyMVar, putMVar, takeMVar) import Control.Monad import Control.Monad.Trans import qualified Data.ByteString.Char8           as B@@ -19,14 +21,15 @@  import Happstack.Server.Types -- 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.Exit (ExitCode(..)) import System.IO import System.IO.Unsafe(unsafePerformIO)+import System.Process (runInteractiveProcess, waitForProcess) -- import Text.XML.HaXml.Verbatim(verbatim) import Happstack.Data hiding (Element) @@ -185,3 +188,27 @@        return $ setHeader "Content-Type" "text/html" $               setHeader "Content-Length" (show $ L.length new) $               res { rsBody = new }+              +-- | Run an external command. Upon failure print status+--   to stderr.+runCommand :: String -> [String] -> IO ()+runCommand cmd args = do +    (_, outP, errP, pid) <- runInteractiveProcess cmd args Nothing Nothing+    let pGetContents h = do mv <- newEmptyMVar+                            let put [] = putMVar mv []+                                put xs = last xs `seq` putMVar mv xs+                            forkIO (hGetContents h >>= put)+                            takeMVar mv+    os <- pGetContents outP+    es <- pGetContents errP+    ec <- waitForProcess pid+    case ec of+      ExitSuccess   -> return ()+      ExitFailure e ->+          do hPutStrLn stderr ("Running process "++unwords (cmd:args)++" FAILED ("++show e++")")+             hPutStrLn stderr os+             hPutStrLn stderr es+             hPutStrLn stderr "Raising error..."+             fail "Running external command failed"++