diff --git a/happstack-server.cabal b/happstack-server.cabal --- a/happstack-server.cabal +++ b/happstack-server.cabal @@ -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 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, diff --git a/src/Happstack/Server/Auth.hs b/src/Happstack/Server/Auth.hs --- a/src/Happstack/Server/Auth.hs +++ b/src/Happstack/Server/Auth.hs @@ -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" diff --git a/src/Happstack/Server/Client.hs b/src/Happstack/Server/Client.hs --- a/src/Happstack/Server/Client.hs +++ b/src/Happstack/Server/Client.hs @@ -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 diff --git a/src/Happstack/Server/Cookie.hs b/src/Happstack/Server/Cookie.hs --- a/src/Happstack/Server/Cookie.hs +++ b/src/Happstack/Server/Cookie.hs @@ -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'. -- diff --git a/src/Happstack/Server/HTTPClient/HTTP.hs b/src/Happstack/Server/HTTPClient/HTTP.hs --- a/src/Happstack/Server/HTTPClient/HTTP.hs +++ b/src/Happstack/Server/HTTPClient/HTTP.hs @@ -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 diff --git a/src/Happstack/Server/Internal/Compression.hs b/src/Happstack/Server/Internal/Compression.hs --- a/src/Happstack/Server/Internal/Compression.hs +++ b/src/Happstack/Server/Internal/Compression.hs @@ -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 diff --git a/src/Happstack/Server/Internal/Cookie.hs b/src/Happstack/Server/Internal/Cookie.hs --- a/src/Happstack/Server/Internal/Cookie.hs +++ b/src/Happstack/Server/Internal/Cookie.hs @@ -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) diff --git a/src/Happstack/Server/Internal/Handler.hs b/src/Happstack/Server/Internal/Handler.hs --- a/src/Happstack/Server/Internal/Handler.hs +++ b/src/Happstack/Server/Internal/Handler.hs @@ -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 diff --git a/src/Happstack/Server/Internal/LogFormat.hs b/src/Happstack/Server/Internal/LogFormat.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/LogFormat.hs @@ -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 diff --git a/src/Happstack/Server/Internal/MessageWrap.hs b/src/Happstack/Server/Internal/MessageWrap.hs --- a/src/Happstack/Server/Internal/MessageWrap.hs +++ b/src/Happstack/Server/Internal/MessageWrap.hs @@ -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' + diff --git a/src/Happstack/Server/Internal/Socket.hs b/src/Happstack/Server/Internal/Socket.hs --- a/src/Happstack/Server/Internal/Socket.hs +++ b/src/Happstack/Server/Internal/Socket.hs @@ -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) diff --git a/src/Happstack/Server/Internal/Types.hs b/src/Happstack/Server/Internal/Types.hs --- a/src/Happstack/Server/Internal/Types.hs +++ b/src/Happstack/Server/Internal/Types.hs @@ -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': +-- +-- + +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 diff --git a/src/Happstack/Server/Routing.hs b/src/Happstack/Server/Routing.hs --- a/src/Happstack/Server/Routing.hs +++ b/src/Happstack/Server/Routing.hs @@ -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': --- --- - -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 diff --git a/src/Happstack/Server/RqData.hs b/src/Happstack/Server/RqData.hs --- a/src/Happstack/Server/RqData.hs +++ b/src/Happstack/Server/RqData.hs @@ -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 diff --git a/src/Happstack/Server/SURI.hs b/src/Happstack/Server/SURI.hs --- a/src/Happstack/Server/SURI.hs +++ b/src/Happstack/Server/SURI.hs @@ -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 diff --git a/src/Happstack/Server/SURI/ParseURI.hs b/src/Happstack/Server/SURI/ParseURI.hs --- a/src/Happstack/Server/SURI/ParseURI.hs +++ b/src/Happstack/Server/SURI/ParseURI.hs @@ -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 diff --git a/src/Happstack/Server/SimpleHTTP.hs b/src/Happstack/Server/SimpleHTTP.hs --- a/src/Happstack/Server/SimpleHTTP.hs +++ b/src/Happstack/Server/SimpleHTTP.hs @@ -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 diff --git a/src/Happstack/Server/Types.hs b/src/Happstack/Server/Types.hs --- a/src/Happstack/Server/Types.hs +++ b/src/Happstack/Server/Types.hs @@ -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 diff --git a/src/Happstack/Server/XSLT.hs b/src/Happstack/Server/XSLT.hs --- a/src/Happstack/Server/XSLT.hs +++ b/src/Happstack/Server/XSLT.hs @@ -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" + +