webserver 0.2.0 → 0.3.0
raw patch · 10 files changed
+379/−285 lines, 10 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Network.Web.Utils: TCPInfo :: HostName -> ServiceName -> HostName -> ServiceName -> TCPInfo
- Network.Web.Utils: data TCPInfo
- Network.Web.Utils: getTCPInfo :: Socket -> IO TCPInfo
- Network.Web.Utils: instance Eq TCPInfo
- Network.Web.Utils: instance Show TCPInfo
- Network.Web.Utils: myAddr :: TCPInfo -> HostName
- Network.Web.Utils: myPort :: TCPInfo -> ServiceName
- Network.Web.Utils: peerAddr :: TCPInfo -> HostName
- Network.Web.Utils: peerPort :: TCPInfo -> ServiceName
- Network.Web.Utils: toURLwoPort :: URI -> String
- Network.Web.Utils: uriHostName :: URI -> String
+ Network.Web.HTTP: fromPersist :: Persist -> ByteString
+ Network.Web.HTTP: fromStatus :: Status -> ByteString
+ Network.Web.HTTP: fromVersion :: Version -> ByteString
+ Network.Web.HTTP: instance Show Request
+ Network.Web.HTTP: toMethod :: ByteString -> Method
+ Network.Web.HTTP: toPersist :: ByteString -> Persist
+ Network.Web.HTTP: toVersion :: ByteString -> Version
+ Network.Web.URI: data URI
+ Network.Web.URI: data URIAuth
+ Network.Web.URI: instance Show URI
+ Network.Web.URI: instance Show URIAuth
+ Network.Web.URI: isAbsoluteURI :: ByteString -> Bool
+ Network.Web.URI: parseURI :: ByteString -> Maybe URI
+ Network.Web.URI: toURLwoPort :: URI -> ByteString
+ Network.Web.URI: unEscapeByteString :: ByteString -> ByteString
+ Network.Web.URI: unEscapeString :: String -> String
+ Network.Web.URI: uriAuthority :: URI -> Maybe URIAuth
+ Network.Web.URI: uriFragment :: URI -> ByteString
+ Network.Web.URI: uriHostName :: URI -> ByteString
+ Network.Web.URI: uriPath :: URI -> ByteString
+ Network.Web.URI: uriPort :: URIAuth -> ByteString
+ Network.Web.URI: uriQuery :: URI -> ByteString
+ Network.Web.URI: uriRegName :: URIAuth -> ByteString
+ Network.Web.URI: uriScheme :: URI -> ByteString
+ Network.Web.URI: uriUserInfo :: URIAuth -> ByteString
- Network.Web.HTTP: FkOther :: String -> FieldKey
+ Network.Web.HTTP: FkOther :: ByteString -> FieldKey
- Network.Web.HTTP: fromFieldKey :: FieldKey -> String
+ Network.Web.HTTP: fromFieldKey :: FieldKey -> ByteString
- Network.Web.HTTP: toFieldKey :: String -> FieldKey
+ Network.Web.HTTP: toFieldKey :: ByteString -> FieldKey
- Network.Web.HTTP: toStatus :: String -> Maybe Status
+ Network.Web.HTTP: toStatus :: ByteString -> Maybe Status
- Network.Web.HTTP: type CT = String
+ Network.Web.HTTP: type CT = ByteString
- Network.Web.HTTP: type FieldValue = String
+ Network.Web.HTTP: type FieldValue = ByteString
- Network.Web.Server.Basic: BasicConfig :: (URI -> Path) -> (FilePath -> Maybe (Integer, Integer) -> IO ByteString) -> (FilePath -> IO (Maybe (Integer, UTCTime))) -> String -> TCPInfo -> BasicConfig
+ Network.Web.Server.Basic: BasicConfig :: (URI -> Path) -> (FilePath -> Maybe (Integer, Integer) -> IO ByteString) -> (FilePath -> IO (Maybe (Integer, UTCTime))) -> ByteString -> TCPInfo -> BasicConfig
- Network.Web.Server.Basic: serverName :: BasicConfig -> String
+ Network.Web.Server.Basic: serverName :: BasicConfig -> ByteString
Files
- Network/Web/Date.hs +7/−4
- Network/Web/HTTP.hs +90/−86
- Network/Web/Params.hs +105/−99
- Network/Web/Server.hs +4/−3
- Network/Web/Server/Basic.hs +17/−15
- Network/Web/Server/CGI.hs +19/−17
- Network/Web/Server/Params.hs +6/−5
- Network/Web/URI.hs +129/−0
- Network/Web/Utils.hs +0/−54
- webserver.cabal +2/−2
Network/Web/Date.hs view
@@ -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
Network/Web/HTTP.hs view
@@ -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 = "<html><body>" ++ show st ++ "</body></html>\n"- len = fromIntegral $ length cs- body = LBS.pack cs+ (<+>) = L.append+ body = "<html><body>" <+> L.pack (show st) <+> "</body></html>\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 = " "
Network/Web/Params.hs view
@@ -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
Network/Web/Server.hs view
@@ -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
Network/Web/Server/Basic.hs view
@@ -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 []
Network/Web/Server/CGI.hs view
@@ -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
Network/Web/Server/Params.hs view
@@ -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 }
+ Network/Web/URI.hs view
@@ -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
− Network/Web/Utils.hs
@@ -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
webserver.cabal view
@@ -1,5 +1,5 @@ Name: webserver-Version: 0.2.0+Version: 0.3.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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