diff --git a/Network/Web/Date.hs b/Network/Web/Date.hs --- a/Network/Web/Date.hs +++ b/Network/Web/Date.hs @@ -1,16 +1,19 @@ module Network.Web.Date (parseDate, utcToDate, HttpDate) where +import qualified Data.ByteString.Char8 as S import Data.Time import Locale import Control.Monad -type HttpDate = String +type HttpDate = S.ByteString -- xxx: ClockTime -> UTCTime ---------------------------------------------------------------- -parseDate :: String -> Maybe UTCTime -parseDate str = rfc1123Date str `mplus` rfc850Date str `mplus` asctimeDate str +parseDate :: S.ByteString -> Maybe UTCTime +parseDate bs = rfc1123Date cs `mplus` rfc850Date cs `mplus` asctimeDate cs + where + cs = S.unpack bs ---------------------------------------------------------------- @@ -46,4 +49,4 @@ ---------------------------------------------------------------- utcToDate :: UTCTime -> HttpDate -utcToDate = formatTime defaultTimeLocale preferredFormat +utcToDate = S.pack . formatTime defaultTimeLocale preferredFormat diff --git a/Network/Web/HTTP.hs b/Network/Web/HTTP.hs --- a/Network/Web/HTTP.hs +++ b/Network/Web/HTTP.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-| HTTP library for HTTP server. -} @@ -16,17 +17,16 @@ import Control.Applicative import Control.Exception (try, throw) -import Data.ByteString.Lazy.Char8 (ByteString) -import qualified Data.ByteString.Lazy.Char8 as LBS hiding (ByteString) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L import Data.Char import Data.List -import Data.Map (Map) -import qualified Data.Map as Map hiding (Map) +import qualified Data.Map as M import Data.Maybe import IO hiding (try) import System.IO.Error hiding (try) -import Network.URI import Network.Web.Params +import Network.Web.URI import Text.Printf ---------------------------------------------------------------- @@ -44,10 +44,10 @@ -- | Key-values of request header , reqFields :: Fields -- | Entity body if exists - , reqBody :: Maybe ByteString + , reqBody :: Maybe L.ByteString -- | Length of entity body from Content-Length: , reqLength :: Integer -} +} deriving Show {-| Abstract data type of HTTP response. @@ -56,11 +56,11 @@ -- | Response status rspStatus :: Status , rspFields :: Fields - , rspBody :: Maybe ByteString -- Nothing -> No entity / No CL: - -- Just bs - -- Just bs.empty - , rspLength :: Maybe Integer -- Nothing -> chunked or close - -- Just x -> CL: x + , rspBody :: Maybe L.ByteString -- Nothing -> No entity / No CL: + -- Just bs + -- Just bs.empty + , rspLength :: Maybe Integer -- Nothing -> chunked or close + -- Just x -> CL: x , rspLogMsg :: String } @@ -118,15 +118,15 @@ , rspFields = flds } where - cs = "" ++ show st ++ "\n" - len = fromIntegral $ length cs - body = LBS.pack cs + (<+>) = L.append + body = "" <+> L.pack (show st) <+> "\n" + len = fromIntegral $ L.length body flds = toFields kvs {-| A function to make 'Response'. -} -makeResponse2 :: Status -> Maybe ByteString -> Maybe Integer -> [(FieldKey,FieldValue)] -> Response +makeResponse2 :: Status -> Maybe L.ByteString -> Maybe Integer -> [(FieldKey,FieldValue)] -> Response makeResponse2 st mval mlen kvs = defaultResponse { rspStatus = st , rspBody = mval , rspLength = mlen @@ -138,7 +138,7 @@ {-| A function to make 'Response'. -} -makeResponse3 :: Status -> Maybe ByteString -> Maybe Integer -> Fields -> Response +makeResponse3 :: Status -> Maybe L.ByteString -> Maybe Integer -> Fields -> Response makeResponse3 st mval mlen flds = defaultResponse { rspStatus = st , rspBody = mval , rspLength = mlen @@ -173,14 +173,14 @@ let req2 = req1 { reqURI = uri, reqFields = flds } receiveBody hdl flds req2 -isEOH :: String -> Bool -isEOH l = null l || l == "\r" +isEOH :: S.ByteString -> Bool +isEOH l = S.null l || l == "\r" -receiveRequestLine :: Handle -> IO (Method,String,Version) +receiveRequestLine :: Handle -> IO (Method,S.ByteString,Version) receiveRequestLine hdl = parseRequestLine <$> skipNullLines where skipNullLines = do - l <- hGetLine hdl + l <- S.hGetLine hdl if isEOH l then skipNullLines else return l @@ -192,27 +192,29 @@ receiveFields hdl = toFields . map parseField <$> getHeaderLines where getHeaderLines = do - l <- hGetLine hdl + l <- S.hGetLine hdl if isEOH l then return [] else (l:) <$> getHeaderLines -toURI :: String -> Fields -> IO URI +toURI :: S.ByteString -> Fields -> IO URI toURI url fields = maybe (fail "toURI") return $ toURI' url fields -toURI' :: String -> Fields -> Maybe URI +toURI' :: S.ByteString -> Fields -> Maybe URI toURI' url fields | isAbsoluteURI url = parseURI url | otherwise = lookupField' FkHost fields >>= \host -> - parseURI $ "http://" ++ host ++ url + parseURI $ "http://" +++ host +++ url + where + (+++) = S.append receiveBody :: Handle -> Fields -> Request -> IO Request receiveBody hdl flds req = case lookupField' FkContentLength flds of Nothing -> return req - Just cs -> do - let len = read cs - body <- LBS.hGet hdl (fromIntegral len) + Just bs -> do + let Just (len,_) = S.readInteger bs -- xxx + body <- L.hGet hdl (fromIntegral len) return req { reqBody = Just body, reqLength = len } ---------------------------------------------------------------- @@ -225,83 +227,83 @@ -} respond :: Handle -> Version -> Persist -> Response -> IO () -respond h ver persist rsp = do - sendStatusLine h ver rsp - sendResponseFields h ver persist rsp - hPutStr h crlf - sendResponseBody h ver rsp - hFlush h `catch` ignore +respond hdl ver persist rsp = do + sendStatusLine hdl ver rsp + sendResponseFields hdl ver persist rsp + S.hPutStr hdl crlf + sendResponseBody hdl ver rsp + hFlush hdl `catch` ignore where ignore _ = return () sendStatusLine :: Handle -> Version -> Response -> IO () -sendStatusLine h ver rsp = do - hPutStr h $ show ver - hPutStr h spc - hPutStr h $ show (rspStatus rsp) -- including reason-phrase - hPutStr h crlf +sendStatusLine hdl ver rsp = do + S.hPutStr hdl $ fromVersion ver + S.hPutStr hdl spc + S.hPutStr hdl $ fromStatus (rspStatus rsp) -- including reason-phrase + S.hPutStr hdl crlf sendResponseFields :: Handle -> Version -> Persist -> Response -> IO () -sendResponseFields h ver persist rsp = do +sendResponseFields hdl ver persist rsp = do putFields putContentLength putTransferEncoding putConnection where - putFields = hPutStr h . concatMap composeField . fromFields $ getFields rsp + putFields = S.hPutStr hdl . S.concat . map composeField . fromFields $ getFields rsp putContentLength = case rspBody rsp >> rspLength rsp of - Just len -> hPutStr h $ composeField (FkContentLength, show len) + Just len -> S.hPutStr hdl $ composeField (FkContentLength, S.pack (show len)) Nothing -> return () putTransferEncoding = if ver == HTTP11 && isJust (rspBody rsp) && isNothing (rspLength rsp) - then hPutStr h $ composeField (FkTransferEncoding, "chunked") + then S.hPutStr hdl $ composeField (FkTransferEncoding, "chunked") else return () - putConnection = hPutStr h $ composeField (FkConnection, show persist) + putConnection = S.hPutStr hdl $ composeField (FkConnection, fromPersist persist) sendResponseBody :: Handle -> Version -> Response -> IO () -sendResponseBody h ver rsp = +sendResponseBody hdl ver rsp = case rspBody rsp of Just body -> case rspLength rsp of - Just _ -> LBS.hPut h body + Just _ -> L.hPut hdl body Nothing -> if ver == HTTP10 - then LBS.hPut h body - else sendChunk h body + then L.hPut hdl body + else sendChunk hdl body Nothing -> return () -sendChunk :: Handle -> ByteString -> IO () -sendChunk h body = do - let (fcnk,rest) = LBS.splitAt chunkSize body - if LBS.null rest +sendChunk :: Handle -> L.ByteString -> IO () +sendChunk hdl body = do + let (fcnk,rest) = L.splitAt chunkSize body + if L.null rest then do - putChunk fcnk $ toHex (LBS.length fcnk) + putChunk fcnk $ toHex (L.length fcnk) putLastChunk + S.hPutStr hdl crlf else do putChunk fcnk defSize - sendChunk h rest + sendChunk hdl rest where chunkSize = 1024 * 4 defSize = toHex chunkSize - toHex = printf "%X" + toHex = S.pack . printf "%X" putChunk cnk siz = do - hPutStr h siz - hPutStr h crlf - LBS.hPut h cnk - hPutStr h crlf + S.hPutStr hdl siz + S.hPutStr hdl crlf + L.hPut hdl cnk + S.hPutStr hdl crlf putLastChunk = do - hPutStr h "0" - hPutStr h crlf - hPutStr h crlf + S.hPutStr hdl "0" + S.hPutStr hdl crlf ---------------------------------------------------------------- {-| Abstract data type for Key-values of HTTP header. -} -newtype Fields = Fields (Map FieldKey FieldValue) deriving Show +newtype Fields = Fields (M.Map FieldKey FieldValue) deriving Show emptyFields :: Fields -emptyFields = Fields Map.empty +emptyFields = Fields M.empty {-| Looking up the HTTP field value. @@ -315,7 +317,7 @@ lookupField' :: FieldKey -> Fields -> Maybe FieldValue lookupField' key (Fields fields) = maybe Nothing (Just . trim) mvalue where - mvalue = Map.lookup key fields + mvalue = M.lookup key fields {-| Inserting the HTTP field. @@ -329,50 +331,52 @@ Inserting the HTTP field. -} insertField' :: FieldKey -> FieldValue -> Fields -> Fields -insertField' key val (Fields fields) = Fields (Map.insert key val fields) +insertField' key val (Fields fields) = Fields (M.insert key val fields) toFields :: [(FieldKey,FieldValue)] -> Fields -toFields kvs = Fields (Map.fromList kvs) +toFields kvs = Fields (M.fromList kvs) fromFields :: Fields -> [(FieldKey,FieldValue)] -fromFields (Fields fields) = Map.toList fields +fromFields (Fields fields) = M.toList fields copyFields :: Fields -> Fields copyFields = toFields . map (\(x,y) -> (x, trim y)) . fromFields ---------------------------------------------------------------- -composeField :: (FieldKey,FieldValue) -> String -composeField (k,v) = fromFieldKey k ++ ": " ++ v ++ crlf +composeField :: (FieldKey,FieldValue) -> S.ByteString +composeField (k,v) = fromFieldKey k +++ ": " +++ v +++ crlf + where + (+++) = S.append -parseField :: String -> (FieldKey,FieldValue) -parseField l = let kv = break (==':') (chomp l) +parseField :: S.ByteString -> (FieldKey,FieldValue) +parseField l = let kv = S.break (==':') (chomp l) in toKeyValue kv where - toKeyValue (k,"") = (toFieldKey k, "") - toKeyValue (k,_:v) = (toFieldKey k, v) -- v is trimmed by lookupField + toKeyValue (k,"") = (toFieldKey k, "") + toKeyValue (k,bs) = (toFieldKey k, S.tail bs) -- bs is trimmed by lookupField -parseRequestLine :: String -> (Method,String,Version) -parseRequestLine l = let (m,l') = break (==' ') (chomp l) - (u,v') = break (==' ') (chop l') +parseRequestLine :: S.ByteString -> (Method,S.ByteString,Version) +parseRequestLine l = let (m,l') = S.break (==' ') (chomp l) + (u,v') = S.break (==' ') (chop l') v = trim v' - in (read m, u, read v) + in (toMethod m, u, toVersion v) ---------------------------------------------------------------- -chop :: String -> String -chop = dropWhile isSpace +chop :: S.ByteString -> S.ByteString +chop = S.dropWhile isSpace -chomp :: String -> String -chomp = fst . break (=='\r') +chomp :: S.ByteString -> S.ByteString +chomp = fst . S.break (=='\r') -trim :: String -> String -trim = reverse . chop . reverse . chop +trim :: S.ByteString -> S.ByteString +trim = S.reverse . chop . S.reverse . chop ---------------------------------------------------------------- -crlf :: String +crlf :: S.ByteString crlf = "\r\n" -spc :: String +spc :: S.ByteString spc = " " diff --git a/Network/Web/Params.hs b/Network/Web/Params.hs --- a/Network/Web/Params.hs +++ b/Network/Web/Params.hs @@ -1,19 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-| Parameters of HTTP. -} -module Network.Web.Params (Method(..), Version(..), Status(..), - toStatus, badStatus, - Persist(..), ServerException(..), - FieldKey(..), FieldValue, - toFieldKey, fromFieldKey, - CT, textHtml, selectContentType) where +module Network.Web.Params ( + Method(..), toMethod + , Version(..), toVersion, fromVersion + , Status(..), toStatus, fromStatus, badStatus + , Persist(..), toPersist, fromPersist + , ServerException(..) + , FieldKey(..), FieldValue + , toFieldKey, fromFieldKey + , CT, textHtml, selectContentType + ) where import Control.Exception +import qualified Data.ByteString.Char8 as S import Data.Char -import Data.Map (Map) -import qualified Data.Map as Map hiding (Map) +import qualified Data.Map as M import Data.Typeable ---------------------------------------------------------------- @@ -24,33 +29,27 @@ data Method = GET | HEAD | POST | PUT | DELETE | TRACE | CONNECT | UnknownMethod deriving (Show,Eq,Enum,Bounded) -methodAlist :: [(String,Method)] +methodAlist :: [(S.ByteString,Method)] methodAlist = let methods = [minBound..maxBound] - in zip (map show methods) methods - -readMethod :: String -> Method -readMethod s = maybe UnknownMethod id $ lookup s methodAlist + in zip (map (S.pack . show) methods) methods -instance Read Method where - readsPrec _ s = [(readMethod s,"")] +toMethod :: S.ByteString -> Method +toMethod s = maybe UnknownMethod id $ lookup s methodAlist ---------------------------------------------------------------- {-| Versions of HTTP. -} -data Version = HTTP10 | HTTP11 deriving Eq - -instance Show Version where - show HTTP10 = "HTTP/1.0" - show HTTP11 = "HTTP/1.1" +data Version = HTTP10 | HTTP11 deriving (Eq,Show) -readVersion :: String -> Version -readVersion "HTTP/1.1" = HTTP11 -readVersion _ = HTTP10 +fromVersion :: Version -> S.ByteString +fromVersion HTTP10 = "HTTP/1.0" +fromVersion HTTP11 = "HTTP/1.1" -instance Read Version where - readsPrec _ s = [(readVersion s,"")] +toVersion :: S.ByteString -> Version +toVersion "HTTP/1.1" = HTTP11 +toVersion _ = HTTP10 ---------------------------------------------------------------- @@ -76,53 +75,54 @@ -- 5xx | InternalServerError | NotImplemented | BadGateway | ServiceUnavailable | GatewayTimeout | HTTPVersionNotSupported + deriving Show -instance Show Status where - show Continue = "100 Continue" - show SwitchingProtocols = "101 Switching Protocols" - show OK = "200 OK" - show Created = "201 Created" - show Accepted = "202 Accepted" - show NonAuthoritativeInformation = "203 Non-Authoritative Information" - show NoContent = "204 No Content" - show ResetContent = "205 Reset Content" - show (PartialContent _ _) = "206 Partial Content" - show MultipleChoices = "300 Multiple Choices" - show MovedPermanently = "301 Moved Permanently" - show Found = "302 Found" - show SeeOther = "303 See Other" - show NotModified = "304 Not Modified" - show UseProxy = "305 Use Proxy" - show TemporaryRedirect = "307 Temporary Redirect" - show BadRequest = "400 Bad Request" - show Unauthorized = "401 Unauthorized" - show PaymentRequired = "402 Payment Required" - show Forbidden = "403 Forbidden" - show NotFound = "404 Not Found" - show MethodNotAllowed = "405 Method Not Allowed" - show NotAcceptable = "406 Not Acceptable" - show ProxyAuthenticationRequired = "407 Proxy Authentication Required" - show RequestTimeout = "408 RequestTimeout" - show Conflict = "409 Conflict" - show Gone = "410 Gone" - show LengthRequired = "411 Length Required" - show PreconditionFailed = "412 Precondition Failed" - show RequestEntityTooLarge = "413 Request Entity Too Large" - show RequestURITooLarge = "414 Request-URI Too Large" - show UnsupportedMediaType = "415 Unsupported Media Type" - show RequestedRangeNotSatisfiable = "416 Requested Range Not Satisfiable" - show ExpectationFailed = "417 Expectation Failed" - show InternalServerError = "500 Internal Server Error" - show NotImplemented = "501 Not Implemented" - show BadGateway = "502 Bad Gateway" - show ServiceUnavailable = "503 Service Unavailable" - show GatewayTimeout = "504 Gateway Time-out" - show HTTPVersionNotSupported = "505 HTTP Version Not Supported" +fromStatus :: Status -> S.ByteString +fromStatus Continue = "100 Continue" +fromStatus SwitchingProtocols = "101 Switching Protocols" +fromStatus OK = "200 OK" +fromStatus Created = "201 Created" +fromStatus Accepted = "202 Accepted" +fromStatus NonAuthoritativeInformation = "203 Non-Authoritative Information" +fromStatus NoContent = "204 No Content" +fromStatus ResetContent = "205 Reset Content" +fromStatus (PartialContent _ _) = "206 Partial Content" +fromStatus MultipleChoices = "300 Multiple Choices" +fromStatus MovedPermanently = "301 Moved Permanently" +fromStatus Found = "302 Found" +fromStatus SeeOther = "303 See Other" +fromStatus NotModified = "304 Not Modified" +fromStatus UseProxy = "305 Use Proxy" +fromStatus TemporaryRedirect = "307 Temporary Redirect" +fromStatus BadRequest = "400 Bad Request" +fromStatus Unauthorized = "401 Unauthorized" +fromStatus PaymentRequired = "402 Payment Required" +fromStatus Forbidden = "403 Forbidden" +fromStatus NotFound = "404 Not Found" +fromStatus MethodNotAllowed = "405 Method Not Allowed" +fromStatus NotAcceptable = "406 Not Acceptable" +fromStatus ProxyAuthenticationRequired = "407 Proxy Authentication Required" +fromStatus RequestTimeout = "408 RequestTimeout" +fromStatus Conflict = "409 Conflict" +fromStatus Gone = "410 Gone" +fromStatus LengthRequired = "411 Length Required" +fromStatus PreconditionFailed = "412 Precondition Failed" +fromStatus RequestEntityTooLarge = "413 Request Entity Too Large" +fromStatus RequestURITooLarge = "414 Request-URI Too Large" +fromStatus UnsupportedMediaType = "415 Unsupported Media Type" +fromStatus RequestedRangeNotSatisfiable = "416 Requested Range Not Satisfiable" +fromStatus ExpectationFailed = "417 Expectation Failed" +fromStatus InternalServerError = "500 Internal Server Error" +fromStatus NotImplemented = "501 Not Implemented" +fromStatus BadGateway = "502 Bad Gateway" +fromStatus ServiceUnavailable = "503 Service Unavailable" +fromStatus GatewayTimeout = "504 Gateway Time-out" +fromStatus HTTPVersionNotSupported = "505 HTTP Version Not Supported" {-| Converting numeric status to 'Status'. -} -toStatus :: String -> Maybe Status +toStatus :: S.ByteString -> Maybe Status toStatus "200" = Just OK toStatus "302" = Just Found toStatus "400" = Just BadRequest @@ -160,7 +160,7 @@ | FkSetCookie2 | FkStatus | FkTransferEncoding - | FkOther String + | FkOther S.ByteString deriving (Eq,Show,Ord) fieldKeyList :: [FieldKey] @@ -183,7 +183,7 @@ , FkStatus , FkTransferEncoding ] -fieldStringList :: [String] +fieldStringList :: [S.ByteString] fieldStringList = [ "Accept-Language" , "Cache-Control" , "Connection" @@ -206,42 +206,51 @@ {-| Field value of HTTP header. -} -type FieldValue = String +type FieldValue = S.ByteString -stringFieldKey :: Map FieldValue FieldKey -stringFieldKey = Map.fromList (zip fieldStringList fieldKeyList) +stringFieldKey :: M.Map FieldValue FieldKey +stringFieldKey = M.fromList (zip fieldStringList fieldKeyList) -fieldKeyString :: Map FieldKey FieldValue -fieldKeyString = Map.fromList (zip fieldKeyList fieldStringList) +fieldKeyString :: M.Map FieldKey FieldValue +fieldKeyString = M.fromList (zip fieldKeyList fieldStringList) {-| Converting field key to 'FieldKey'. -} -toFieldKey :: String -> FieldKey -toFieldKey str = maybe (FkOther cstr) id $ Map.lookup cstr stringFieldKey +toFieldKey :: S.ByteString -> FieldKey +toFieldKey str = maybe (FkOther cstr) id $ M.lookup cstr stringFieldKey where cstr = capitalize str {-| Converting 'FieldKey' to field key. -} -fromFieldKey :: FieldKey -> String +fromFieldKey :: FieldKey -> S.ByteString fromFieldKey (FkOther cstr) = cstr -fromFieldKey key = maybe err id $ Map.lookup key fieldKeyString +fromFieldKey key = maybe err id $ M.lookup key fieldKeyString where err = error "fromFieldKey" -capitalize :: String -> String +(<:>) :: Char -> S.ByteString -> S.ByteString +(<:>) = S.cons + +capitalize :: S.ByteString -> S.ByteString capitalize s = toup s where - toup [] = [] - toup (x:xs) - | isLetter x = toUpper x : stay xs - | otherwise = x : toup xs - stay [] = [] - stay (x:xs) - | isLetter x = x : stay xs - | otherwise = x : toup xs + toup "" = "" + toup bs + | isLetter x = toUpper x <:> stay xs + | otherwise = x <:> toup xs + where + x = S.head bs + xs = S.tail bs + stay "" = "" + stay bs + | isLetter x = x <:> stay xs + | otherwise = x <:> toup xs + where + x = S.head bs + xs = S.tail bs ---------------------------------------------------------------- @@ -249,7 +258,7 @@ The type for Content-Type. -} -type CT = String +type CT = S.ByteString {-| Selecting a value of Content-Type from a file suffix. @@ -289,20 +298,17 @@ ---------------------------------------------------------------- -- | The type for persist connection or not -data Persist = Close | Keep | PerUnknown deriving Eq - -instance Show Persist where - show Close = "close" - show Keep = "keep-alive" - show PerUnknown = "unknown" +data Persist = Close | Keep | PerUnknown deriving (Eq,Show) -instance Read Persist where - readsPrec _ s = [(readPersist s,"")] +fromPersist :: Persist -> S.ByteString +fromPersist Close = "close" +fromPersist Keep = "keep-alive" +fromPersist PerUnknown = "unknown" -readPersist :: String -> Persist -readPersist cs = readPersist' (downcase cs) +toPersist :: S.ByteString -> Persist +toPersist cs = readPersist' (downcase cs) where - downcase = map toLower + downcase = S.map toLower readPersist' "close" = Close readPersist' "keep-alive" = Keep readPersist' _ = PerUnknown diff --git a/Network/Web/Server.hs b/Network/Web/Server.hs --- a/Network/Web/Server.hs +++ b/Network/Web/Server.hs @@ -6,6 +6,7 @@ import Control.Exception import Control.Monad import Control.Applicative +import qualified Data.ByteString.Char8 as S import Data.Char import Data.Maybe import Data.Time @@ -110,14 +111,14 @@ -- CGI and HTTP/1.0 -> Close -checkPersist :: Version -> Maybe String -> Response -> Persist +checkPersist :: Version -> Maybe S.ByteString -> Response -> Persist checkPersist HTTP11 Nothing _ = Keep checkPersist HTTP11 (Just cnct) _ - | read cnct == Close = Close + | toPersist cnct == Close = Close | otherwise = Keep checkPersist HTTP10 Nothing _ = Close checkPersist HTTP10 (Just cnct) rsp - | read cnct == Keep = if isJust (rspBody rsp) && + | toPersist cnct == Keep = if isJust (rspBody rsp) && isNothing (rspLength rsp) then Close else Keep diff --git a/Network/Web/Server/Basic.hs b/Network/Web/Server/Basic.hs --- a/Network/Web/Server/Basic.hs +++ b/Network/Web/Server/Basic.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + {-| Creating basic 'WebServer'. Created 'WebServer' can handle GET \/ HEAD \/ POST; @@ -11,11 +13,11 @@ import Control.Applicative import Control.Monad -import Data.ByteString.Lazy.Char8 (ByteString) -import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L import Data.List import Data.Time -import Network.URI hiding (path) +import Network.TCPInfo import Network.Web.Date import Network.Web.HTTP import Network.Web.Server @@ -23,7 +25,7 @@ import Network.Web.Server.Lang import Network.Web.Server.Params import Network.Web.Server.Range -import Network.Web.Utils +import Network.Web.URI import System.FilePath ---------------------------------------------------------------- @@ -59,7 +61,7 @@ addPeerToLog rsp = rsp { rspLogMsg = logmsg} peer = peerAddr (tcpInfo cnf) logmsg = "[" ++ peer ++ "] " ++ maybe "" uri mreq - uri req = "\"" ++ toURLwoPort (reqURI req) ++ "\"" + uri req = "\"" ++ (S.unpack . toURLwoPort . reqURI) req ++ "\"" ---------------------------------------------------------------- @@ -99,7 +101,7 @@ processPOST cnf req = tryPost cnf req languages :: Request -> [String] -languages req = maybe [] (parseLang) $ lookupField FkAcceptLanguage req +languages req = maybe [] (parseLang . S.unpack) $ lookupField FkAcceptLanguage req ---------------------------------------------------------------- @@ -164,7 +166,7 @@ val <- obtain cnf file' $ Just (skip,len) return . Just $ response st val len ct modified Just st -> - return . Just $ response st LBS.empty 0 ct modified + return . Just $ response st L.empty 0 ct modified _ -> return Nothing -- never reached ifmodified :: Request -> Integer -> UTCTime -> Maybe Status @@ -193,8 +195,8 @@ unconditional req size _ = maybe (Just OK) (range size) $ lookupField FkRange req -range :: Integer -> String -> Maybe Status -range size rng = case skipAndSize rng size of +range :: Integer -> S.ByteString -> Maybe Status +range size rng = case skipAndSize (S.unpack rng) size of Nothing -> Just RequestedRangeNotSatisfiable Just (skip,len) -> Just (PartialContent skip len) @@ -227,9 +229,9 @@ redirectURI :: URI -> Maybe URI redirectURI uri = let path = uriPath uri - in if hasTrailingPathSeparator path + in if "/" `S.isSuffixOf` path then Nothing - else Just uri { uriPath = addTrailingPathSeparator path} + else Just uri { uriPath = path `S.append` "/" } tryRedirect :: BasicConfig -> URI -> [String] -> IO (Maybe Response) tryRedirect cnf uri langs = @@ -265,20 +267,20 @@ ---------------------------------------------------------------- -response :: Status -> ByteString -> Integer -> CT -> String -> Response +response :: Status -> L.ByteString -> Integer -> CT -> HttpDate -> Response response st val len ct modified = makeResponse2 st (Just val) (Just len) kvs where kvs = [(FkContentType,ct),(FkLastModified,modified)] ---------------------------------------------------------------- -responseOK :: CT -> String -> Response -responseOK ct modified = makeResponse2 OK (Just LBS.empty) (Just 0) kvs +responseOK :: CT -> HttpDate -> Response +responseOK ct modified = makeResponse2 OK (Just L.empty) (Just 0) kvs where kvs = [(FkContentType,ct),(FkLastModified,modified)] responseRedirect :: URI -> Response -responseRedirect rurl = makeResponse MovedPermanently [(FkLocation,show rurl)] +responseRedirect rurl = makeResponse MovedPermanently [(FkLocation,S.pack . show $ rurl)] responseNotFound :: Response responseNotFound = makeResponse NotFound [] diff --git a/Network/Web/Server/CGI.hs b/Network/Web/Server/CGI.hs --- a/Network/Web/Server/CGI.hs +++ b/Network/Web/Server/CGI.hs @@ -1,14 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} + module Network.Web.Server.CGI (tryGetCGI) where import Control.Applicative import Control.Concurrent -import Data.ByteString.Lazy.Char8 (ByteString) -import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L import Data.Char -import Network.URI +import Network.TCPInfo import Network.Web.HTTP import Network.Web.Server.Params -import Network.Web.Utils +import Network.Web.URI import System.IO import System.Posix.IO import System.Process @@ -45,13 +47,13 @@ type ENVVARS = [(String,String)] -execCGI :: FilePath -> ENVVARS -> Maybe Handle -> Maybe Handle -> Maybe (Handle,ByteString) -> IO () +execCGI :: FilePath -> ENVVARS -> Maybe Handle -> Maybe Handle -> Maybe (Handle,L.ByteString) -> IO () execCGI prog envVars sti sto mhb = do runProcess prog [] Nothing (Just envVars) sti sto Nothing case mhb of Nothing -> return () Just (whdl,body) -> do - LBS.hPut whdl body + L.hPut whdl body hClose whdl makeEnv :: BasicConfig -> Request -> URLParameter -> ScriptName -> ENVVARS @@ -60,23 +62,23 @@ baseEnv = [("GATEWAY_INTERFACE", gatewayInterface) ,("SCRIPT_NAME", snm) ,("REQUEST_METHOD", show (reqMethod req)) - ,("SERVER_NAME", uriHostName (reqURI req)) + ,("SERVER_NAME", S.unpack . uriHostName . reqURI $ req) ,("SERVER_PORT", myPort (tcpInfo cnf)) ,("REMOTE_ADDR", peerAddr (tcpInfo cnf)) ,("SERVER_PROTOCOL", show (reqVersion req)) - ,("SERVER_SOFTWARE", serverName cnf)] + ,("SERVER_SOFTWARE", S.unpack . serverName $ cnf)] pathOrQuery par - | par == "" = [("QUERY_STRING","") - ,("PATH_INFO", "")] - | head par == '?' = [("QUERY_STRING", unEscapeString(tail par)) - ,("PATH_INFO", "")] - | otherwise = [("QUERY_STRING","") - ,("PATH_INFO", unEscapeString par)] + | par == "" = [("QUERY_STRING","") + ,("PATH_INFO", "")] + | head par == '?' = [("QUERY_STRING", unEscapeString . tail $ par) + ,("PATH_INFO", "")] + | otherwise = [("QUERY_STRING","") + ,("PATH_INFO", unEscapeString $ par)] addLength = add "CONTENT_LENGTH" (lookupField FkContentLength req) addType = add "CONTENT_TYPE" (lookupField FkContentType req) addCookie = add "HTTP_COOKIE" (lookupField FkCookie req) add _ Nothing envs = envs - add key (Just val) envs = (key,val) : envs + add key (Just val) envs = (key,S.unpack val) : envs processCGIoutput :: Handle -> IO Response processCGIoutput rhdl = do @@ -85,11 +87,11 @@ Nothing -> return responseInternalServerError Just _ -> do let st = maybe OK id (lookupField' FkStatus flds >>= toStatus) - responseAny st flds <$> LBS.hGetContents rhdl + responseAny st flds <$> L.hGetContents rhdl ---------------------------------------------------------------- -responseAny :: Status -> Fields -> ByteString -> Response +responseAny :: Status -> Fields -> L.ByteString -> Response responseAny st flds val = makeResponse3 st (Just val) Nothing flds' where flds' = case lookupField' FkSetCookie2 flds of diff --git a/Network/Web/Server/Params.hs b/Network/Web/Server/Params.hs --- a/Network/Web/Server/Params.hs +++ b/Network/Web/Server/Params.hs @@ -1,9 +1,10 @@ module Network.Web.Server.Params where -import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L import Data.Time -import Network.URI -import Network.Web.Utils +import Network.TCPInfo +import Network.Web.URI {-| The configuration for the basic web server. @@ -13,12 +14,12 @@ mapper :: URI -> Path -- | Resource obtaining function. The second argument is -- (offset of the resource, and length from the offset). - , obtain :: FilePath -> Maybe (Integer,Integer) -> IO ByteString + , obtain :: FilePath -> Maybe (Integer,Integer) -> IO L.ByteString -- | A function to return the size of the resource and -- its modification time if exists. , info :: FilePath -> IO (Maybe (Integer, UTCTime)) -- | A server name specified the Server: field. - , serverName :: String + , serverName :: S.ByteString -- | 'TCPInfo' for passing CGI. (See c10k library.) , tcpInfo :: TCPInfo } diff --git a/Network/Web/URI.hs b/Network/Web/URI.hs new file mode 100644 --- /dev/null +++ b/Network/Web/URI.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| + Parser for URI +-} + +module Network.Web.URI ( + URI, uriScheme, uriAuthority, uriPath, uriQuery, uriFragment + , URIAuth, uriUserInfo, uriRegName, uriPort + , parseURI + , uriHostName, toURLwoPort + , isAbsoluteURI, unEscapeString, unEscapeByteString + ) where + +import qualified Data.ByteString.Char8 as S +import Data.Char + +{-| + Abstract data type for URI +-} +data URI = URI { + uriScheme :: S.ByteString + , uriAuthority :: Maybe URIAuth + , uriPath :: S.ByteString + , uriQuery :: S.ByteString + , uriFragment :: S.ByteString +} deriving Show + +{-| + Abstract data type for URI Authority +-} +data URIAuth = URIAuth { + uriUserInfo :: S.ByteString + , uriRegName :: S.ByteString + , uriPort :: S.ByteString +} deriving Show + +---------------------------------------------------------------- + +{-| + Parsing URI. +-} +parseURI :: S.ByteString -> Maybe URI +parseURI url = Just URI { + uriScheme = "http:" + , uriAuthority = Just URIAuth { + uriUserInfo = "" + , uriRegName = host + , uriPort = port + } + , uriPath = path + , uriQuery = query + , uriFragment = "" + } + where + (auth,pathQuery) = parseURL url + (path,query) = parsePathQuery pathQuery + (host,port) = parseAuthority auth + +parseURL :: S.ByteString -> (S.ByteString,S.ByteString) +parseURL reqUri = let (hostServ,path) = S.break (=='/') $ S.drop 7 reqUri + in (hostServ, checkPath path) + where + checkPath "" = "/" + checkPath path = path + +parsePathQuery :: S.ByteString -> (S.ByteString,S.ByteString) +parsePathQuery = S.break (=='?') + +parseAuthority :: S.ByteString -> (S.ByteString,S.ByteString) +parseAuthority hostServ + | serv == "" = (host, "") + | otherwise = (host, S.tail serv) + where + (host,serv) = S.break (==':') hostServ + +---------------------------------------------------------------- + +{-| + Getting a hostname from 'URI'. +-} +uriHostName :: URI -> S.ByteString +uriHostName uri = maybe "" uriRegName $ uriAuthority uri + +{-| + Making a URL string from 'URI' without port. +-} +toURLwoPort :: URI -> S.ByteString +toURLwoPort uri = uriScheme uri +++ "//" +++ uriHostName uri +++ uriPath uri +++ uriQuery uri + where + (+++) = S.append + +---------------------------------------------------------------- + +{-| + Checking whether or not URI starts with \"http://\". +-} +isAbsoluteURI :: S.ByteString -> Bool +isAbsoluteURI url = "http://" `S.isPrefixOf` url + +{-| + Decoding the %XX encoding. +-} +unEscapeByteString :: S.ByteString -> S.ByteString +unEscapeByteString "" = "" +unEscapeByteString bs + | S.head bs == '%' && S.length bs >= 3 + && isHexDigit c1 && isHexDigit c2 = dc <:> unEscapeByteString cs + where + [_,c1,c2] = S.unpack $ S.take 3 bs + cs = S.drop 3 bs + dc = chr $ digitToInt c1 * 16 + digitToInt c2 + (<:>) = S.cons +unEscapeByteString bs = c <:> unEscapeByteString cs + where + c = S.head bs + cs = S.tail bs + (<:>) = S.cons + +{-| + Decoding the %XX encoding. + -} +unEscapeString :: String -> String +unEscapeString [] = "" +unEscapeString ('%':c1:c2:cs) + | isHexDigit c1 && isHexDigit c2 = dc : unEscapeString cs + where + dc = chr $ digitToInt c1 * 16 + digitToInt c2 +unEscapeString (c:cs) = c : unEscapeString cs diff --git a/Network/Web/Utils.hs b/Network/Web/Utils.hs deleted file mode 100644 --- a/Network/Web/Utils.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-| - Utility functions. --} -module Network.Web.Utils where - -import Data.List -import Network.Socket -import Network.URI -import System.IO - -{-| - Getting a hostname from 'URI'. --} -uriHostName :: URI -> String -uriHostName uri = maybe "" uriRegName $ uriAuthority uri - -{-| - Making a URL string from 'URI' without port. --} -toURLwoPort :: URI -> String -toURLwoPort uri = uriScheme uri ++ "//" ++ uriHostName uri ++ uriPath uri ++ uriQuery uri - ----------------------------------------------------------------- - -{-| - TCP connection information. --} -data TCPInfo = TCPInfo { - -- | Local IP address - myAddr :: HostName - -- | Local port number - , myPort :: ServiceName - -- | Remote IP address - , peerAddr :: HostName - -- | Remote port number - , peerPort :: ServiceName - } deriving (Eq,Show) - -{-| - Getting TCP connection information. --} -getTCPInfo :: Socket -> IO TCPInfo -getTCPInfo sock = do - (Just vMyAddr, Just vMyPort) <- getSocketName sock >>= getInfo - (Just vPeerAddr, Just vPeerPort) <- getPeerName sock >>= getInfo - return TCPInfo { myAddr = strip vMyAddr - , myPort = vMyPort - , peerAddr = strip vPeerAddr - , peerPort = vPeerPort} - where - getInfo = getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True - strip x - | "::ffff:" `isPrefixOf` x = drop 7 x - | otherwise = x diff --git a/webserver.cabal b/webserver.cabal --- a/webserver.cabal +++ b/webserver.cabal @@ -1,5 +1,5 @@ Name: webserver -Version: 0.2.0 +Version: 0.3.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -14,7 +14,7 @@ Exposed-Modules: Network.Web.HTTP Network.Web.Server Network.Web.Server.Basic - Network.Web.Utils + Network.Web.URI Other-Modules: Network.Web.Date Network.Web.Params Network.Web.Server.CGI