From: PHO Date: Thu, 25 Aug 2011 18:48:27 +0000 (+0900) Subject: Format and others X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=8510a37;p=Lucu.git Format and others Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index cb3f4a8..5a241b7 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} -- |Configurations for the Lucu httpd like a port to listen. module Network.HTTP.Lucu.Config ( Config(..) @@ -5,68 +9,68 @@ module Network.HTTP.Lucu.Config , defaultConfig ) where - -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import Network -import Network.BSD -import Network.HTTP.Lucu.MIMEType.Guess -import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap -import OpenSSL.Session -import System.IO.Unsafe +import Data.Ascii (Ascii) +import Data.Text (Text) +import qualified Data.Text as T +import Network +import Network.BSD +import Network.HTTP.Lucu.MIMEType.Guess +import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap +import OpenSSL.Session +import System.IO.Unsafe -- |Configuration record for the Lucu httpd. You need to use -- 'defaultConfig' or setup your own configuration to run the httpd. data Config = Config { -- |A string which will be sent to clients as \"Server\" field. - cnfServerSoftware :: !Strict.ByteString + cnfServerSoftware ∷ !Ascii -- |The host name of the server. This value will be used in -- built-in pages like \"404 Not Found\". - , cnfServerHost :: !Strict.ByteString + , cnfServerHost ∷ !Text -- |A port number (or service name) to listen to HTTP clients. - , cnfServerPort :: !ServiceName + , cnfServerPort ∷ !ServiceName -- |Local IPv4 address to listen to both HTTP and HTTPS -- clients. Set this to @('Just' "0.0.0.0")@ if you want to accept -- any IPv4 connections. Set this to 'Nothing' to disable IPv4. - , cnfServerV4Addr :: !(Maybe HostName) + , cnfServerV4Addr ∷ !(Maybe HostName) -- |Local IPv6 address to listen to both HTTP and HTTPS -- clients. Set this to @('Just' "::")@ if you want to accept any -- IPv6 connections. Set this to 'Nothing' to disable IPv6. Note -- that there is currently no way to assign separate ports to IPv4 -- and IPv6 server sockets. - , cnfServerV6Addr :: !(Maybe HostName) + , cnfServerV6Addr ∷ !(Maybe HostName) -- |Configuration for HTTPS connections. Set this 'Nothing' to -- disable HTTPS. - , cnfSSLConfig :: !(Maybe SSLConfig) + , cnfSSLConfig ∷ !(Maybe SSLConfig) -- |The maximum number of requests to accept in one connection -- simultaneously. If a client exceeds this limitation, its last -- request won't be processed until a response for its earliest -- pending request is sent back to the client. - , cnfMaxPipelineDepth :: !Int + , cnfMaxPipelineDepth ∷ !Int -- |The maximum length of request entity to accept in bytes. Note -- that this is nothing but the default value which is used when -- 'Network.HTTP.Lucu.Resource.input' and such like are applied to -- 'Network.HTTP.Lucu.Resource.defaultLimit', so there is no -- guarantee that this value always constrains all the requests. - , cnfMaxEntityLength :: !Int + , cnfMaxEntityLength ∷ !Int -- |The maximum length of chunk to output. This value is used by -- 'Network.HTTP.Lucu.Resource.output' and such like to limit the -- chunk length so you can safely output an infinite string (like -- a lazy stream of \/dev\/random) using those actions. - , cnfMaxOutputChunkLength :: !Int + , cnfMaxOutputChunkLength ∷ !Int -- | Whether to dump too late abortion to the stderr or not. See -- 'Network.HTTP.Lucu.Abortion.abort'. - , cnfDumpTooLateAbortionToStderr :: !Bool + , cnfDumpTooLateAbortionToStderr ∷ !Bool -- |A mapping from extension to MIME Type. This value is used by -- 'Network.HTTP.Lucu.StaticFile.staticFile' to guess the MIME @@ -79,7 +83,7 @@ data Config = Config { -- good idea to use GnomeVFS -- () -- instead of vanilla FS. - , cnfExtToMIMEType :: !ExtMap + , cnfExtToMIMEType ∷ !ExtMap } -- |Configuration record for HTTPS connections. @@ -88,19 +92,19 @@ data SSLConfig -- |A port ID to listen to HTTPS clients. Local addresses -- (both for IPv4 and IPv6) will be derived from the parent -- 'Config'. - sslServerPort :: !ServiceName + sslServerPort ∷ !ServiceName -- |An SSL context for accepting connections. - , sslContext :: !SSLContext + , sslContext ∷ !SSLContext } -- |The default configuration. Generally you can use this value as-is, -- or possibly you just want to replace the 'cnfServerSoftware' and -- 'cnfServerPort'. SSL connections are disabled by default. -defaultConfig :: Config +defaultConfig ∷ Config defaultConfig = Config { - cnfServerSoftware = C8.pack "Lucu/1.0" - , cnfServerHost = C8.pack (unsafePerformIO getHostName) + cnfServerSoftware = "Lucu/1.0" + , cnfServerHost = T.pack (unsafePerformIO getHostName) , cnfServerPort = "http" , cnfServerV4Addr = Just "0.0.0.0" , cnfServerV6Addr = Just "::" diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index b5a9341..dea56b3 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -64,9 +64,9 @@ mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b {-# INLINEABLE mkDefaultPage #-} mkDefaultPage !conf !status !msgA = let (# sCode, sMsg #) = statusCode status - sig = concat [ C8.unpack (cnfServerSoftware conf) + sig = concat [ A.toString (cnfServerSoftware conf) , " at " - , C8.unpack (cnfServerHost conf) + , T.unpack (cnfServerHost conf) ] in ( eelem "/" += ( eelem "html" diff --git a/Network/HTTP/Lucu/Format.hs b/Network/HTTP/Lucu/Format.hs index 93c2cda..86bca83 100644 --- a/Network/HTTP/Lucu/Format.hs +++ b/Network/HTTP/Lucu/Format.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE + OverloadedStrings + , ScopedTypeVariables + , UnboxedTuples + , UnicodeSyntax + #-} -- 本當にこんなものを自分で書く必要があったのだらうか。Printf は重いの -- で駄目だが、それ以外のモジュールを探しても見付からなかった。 - module Network.HTTP.Lucu.Format ( fmtInt @@ -8,124 +13,110 @@ module Network.HTTP.Lucu.Format , fmtHex ) where - - -fmtInt :: Int -> Bool -> Int -> Char -> Bool -> Int -> String -fmtInt base upperCase minWidth pad forceSign n - = base `seq` minWidth `seq` pad `seq` forceSign `seq` n `seq` - let raw = reverse $! fmt' (abs n) - sign = if forceSign || n < 0 then - if n < 0 then "-" else "+" - else - "" - padded = padStr (minWidth - length sign) pad raw +import Data.Ascii (AsciiBuilder) +import qualified Data.ByteString.Char8 as BS +import qualified Data.Ascii as A +import Data.Char +import Data.Monoid.Unicode +import Prelude.Unicode + +fmtInt ∷ ∀n. Integral n ⇒ n → Int → n → AsciiBuilder +{-# INLINEABLE fmtInt #-} +fmtInt base minWidth n + = let (# raw, len #) = fmt' (abs n) (∅) 0 in - sign ++ padded + if n < 0 then + ( A.toAsciiBuilder "-" ⊕ + mkPad (minWidth - 1) len ⊕ + raw + ) + else + mkPad minWidth len ⊕ raw where - fmt' :: Int -> String - fmt' m - | m < base = [intToChar upperCase m] - | otherwise = (intToChar upperCase $! m `mod` base) : fmt' (m `div` base) - - -fmtDec :: Int -> Int -> String + fmt' ∷ n → AsciiBuilder → Int → (# AsciiBuilder, Int #) + {-# INLINEABLE fmt' #-} + fmt' x b len + | x < base + = let b' = b ⊕ fromDigit x + in + (# b', len + 1 #) + | otherwise + = let x' = x `div` base + y = x `mod` base + b' = b ⊕ fromDigit y + in + fmt' x' b' (len + 1) + +mkPad ∷ Int → Int → AsciiBuilder +{-# INLINEABLE mkPad #-} +mkPad minWidth len + = A.toAsciiBuilder $ + A.unsafeFromByteString $ + BS.replicate (minWidth - len) '0' + +fmtDec ∷ Integral n ⇒ Int → n → AsciiBuilder +{-# INLINE fmtDec #-} fmtDec minWidth n | minWidth == 2 = fmtDec2 n -- optimization | minWidth == 3 = fmtDec3 n -- optimization | minWidth == 4 = fmtDec4 n -- optimization - | otherwise = fmtInt 10 undefined minWidth '0' False n -{-# INLINE fmtDec #-} - + | otherwise = fmtInt 10 minWidth n -fmtDec2 :: Int -> String +fmtDec2 ∷ Integral n ⇒ n → AsciiBuilder +{-# INLINEABLE fmtDec2 #-} fmtDec2 n - | n < 0 || n >= 100 = fmtInt 10 undefined 2 '0' False n -- fallback - | n < 10 = [ '0' - , intToChar undefined n - ] - | otherwise = [ intToChar undefined (n `div` 10) - , intToChar undefined (n `mod` 10) - ] - - -fmtDec3 :: Int -> String + | n < 0 ∨ n ≥ 100 = fmtInt 10 2 n -- fallback + | n < 10 = A.toAsciiBuilder "0" ⊕ + fromDigit n + | otherwise = fromDigit (n `div` 10) ⊕ + fromDigit (n `mod` 10) + +fmtDec3 ∷ Integral n ⇒ n → AsciiBuilder +{-# INLINEABLE fmtDec3 #-} fmtDec3 n - | n < 0 || n >= 1000 = fmtInt 10 undefined 3 '0' False n -- fallback - | n < 10 = [ '0' - , '0' - , intToChar undefined n - ] - | n < 100 = [ '0' - , intToChar undefined ((n `div` 10) `mod` 10) - , intToChar undefined ( n `mod` 10) - ] - | otherwise = [ intToChar undefined ((n `div` 100) `mod` 10) - , intToChar undefined ((n `div` 10) `mod` 10) - , intToChar undefined ( n `mod` 10) - ] - - -fmtDec4 :: Int -> String + | n < 0 ∨ n ≥ 1000 = fmtInt 10 3 n -- fallback + | n < 10 = A.toAsciiBuilder "00" ⊕ + fromDigit n + | n < 100 = A.toAsciiBuilder "0" ⊕ + fromDigit ((n `div` 10) `mod` 10) ⊕ + fromDigit ( n `mod` 10) + | otherwise = fromDigit (n `div` 100) ⊕ + fromDigit ((n `div` 10) `mod` 10) ⊕ + fromDigit ( n `mod` 10) + +fmtDec4 ∷ Integral n ⇒ n → AsciiBuilder +{-# INLINEABLE fmtDec4 #-} fmtDec4 n - | n < 0 || n >= 10000 = fmtInt 10 undefined 4 '0' False n -- fallback - | n < 10 = [ '0' - , '0' - , '0' - , intToChar undefined n - ] - | n < 100 = [ '0' - , '0' - , intToChar undefined ((n `div` 10) `mod` 10) - , intToChar undefined ( n `mod` 10) - ] - | n < 1000 = [ '0' - , intToChar undefined ((n `div` 100) `mod` 10) - , intToChar undefined ((n `div` 10) `mod` 10) - , intToChar undefined ( n `mod` 10) - ] - | otherwise = [ intToChar undefined ((n `div` 1000) `mod` 10) - , intToChar undefined ((n `div` 100) `mod` 10) - , intToChar undefined ((n `div` 10) `mod` 10) - , intToChar undefined ( n `mod` 10) - ] - - -fmtHex :: Bool -> Int -> Int -> String -fmtHex upperCase minWidth - = fmtInt 16 upperCase minWidth '0' False - - -padStr :: Int -> Char -> String -> String -padStr minWidth pad str - = let delta = minWidth - length str - in - if delta > 0 then - replicate delta pad ++ str - else - str - - -intToChar :: Bool -> Int -> Char -intToChar _ 0 = '0' -intToChar _ 1 = '1' -intToChar _ 2 = '2' -intToChar _ 3 = '3' -intToChar _ 4 = '4' -intToChar _ 5 = '5' -intToChar _ 6 = '6' -intToChar _ 7 = '7' -intToChar _ 8 = '8' -intToChar _ 9 = '9' -intToChar False 10 = 'a' -intToChar True 10 = 'A' -intToChar False 11 = 'b' -intToChar True 11 = 'B' -intToChar False 12 = 'c' -intToChar True 12 = 'C' -intToChar False 13 = 'd' -intToChar True 13 = 'D' -intToChar False 14 = 'e' -intToChar True 14 = 'E' -intToChar False 15 = 'f' -intToChar True 15 = 'F' -intToChar _ _ = undefined + | n < 0 ∨ n ≥ 10000 = fmtInt 10 4 n -- fallback + | n < 10 = A.toAsciiBuilder "000" ⊕ + fromDigit n + | n < 100 = A.toAsciiBuilder "00" ⊕ + fromDigit ((n `div` 10) `mod` 10) ⊕ + fromDigit ( n `mod` 10) + | n < 1000 = A.toAsciiBuilder "0" ⊕ + fromDigit ((n `div` 100) `mod` 10) ⊕ + fromDigit ((n `div` 10) `mod` 10) ⊕ + fromDigit ( n `mod` 10) + | otherwise = fromDigit (n `div` 1000) ⊕ + fromDigit ((n `div` 100) `mod` 10) ⊕ + fromDigit ((n `div` 10) `mod` 10) ⊕ + fromDigit ( n `mod` 10) + +fmtHex ∷ Integral n ⇒ Int → n → AsciiBuilder +{-# INLINE fmtHex #-} +fmtHex = fmtInt 16 + +digitToChar ∷ Integral n ⇒ n → Char +{-# INLINE digitToChar #-} +digitToChar n + | n < 0 = (⊥) + | n < 10 = chr (ord '0' + fromIntegral n ) + | n < 16 = chr (ord 'A' + fromIntegral (n-10)) + | otherwise = (⊥) + +fromDigit ∷ Integral n ⇒ n → AsciiBuilder +{-# INLINE fromDigit #-} +fromDigit = A.toAsciiBuilder ∘ + A.unsafeFromByteString ∘ + BS.singleton ∘ + digitToChar diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 806ed1c..989ad16 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns + , OverloadedStrings , UnicodeSyntax #-} module Network.HTTP.Lucu.Postprocess @@ -7,9 +8,12 @@ module Network.HTTP.Lucu.Postprocess , completeUnconditionalHeaders ) where - +import Control.Applicative import Control.Concurrent.STM import Control.Monad +import Control.Monad.Unicode +import Data.Ascii (Ascii, CIAscii) +import qualified Data.Ascii as A import qualified Data.ByteString as Strict (ByteString) import qualified Data.ByteString.Char8 as C8 hiding (ByteString) import Data.IORef @@ -24,6 +28,7 @@ import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response +import Prelude.Unicode import System.IO.Unsafe {- @@ -59,22 +64,22 @@ import System.IO.Unsafe -} -postprocess :: Interaction -> STM () +postprocess ∷ Interaction → STM () postprocess !itr - = do reqM <- readItr itr itrRequest id - res <- readItr itr itrResponse id + = do reqM ← readItr itr itrRequest id + res ← readItr itr itrResponse id let sc = resStatus res - unless (any (\ p -> p sc) [isSuccessful, isRedirection, isError]) + unless (any (\ p → p sc) [isSuccessful, isRedirection, isError]) $ abortSTM InternalServerError [] $ Just ("The status code is not good for a final status: " ++ show sc) - when (sc == MethodNotAllowed && getHeader (C8.pack "Allow") res == Nothing) + when (sc ≡ MethodNotAllowed ∧ getHeader (C8.pack "Allow") res ≡ Nothing) $ abortSTM InternalServerError [] $ Just ("The status was " ++ show sc ++ " but no Allow header.") - when (sc /= NotModified && isRedirection sc && getHeader (C8.pack "Location") res == Nothing) + when (sc /= NotModified ∧ isRedirection sc ∧ getHeader (C8.pack "Location") res ≡ Nothing) $ abortSTM InternalServerError [] $ Just ("The status code was " ++ show sc ++ " but no Location header.") @@ -82,99 +87,75 @@ postprocess !itr -- itrResponse の内容は relyOnRequest によって變へられてゐる可 -- 能性が高い。 - do oldRes <- readItr itr itrResponse id - newRes <- unsafeIOToSTM - $ completeUnconditionalHeaders (itrConfig itr) oldRes + do oldRes ← readItr itr itrResponse id + newRes ← unsafeIOToSTM + $ completeUnconditionalHeaders (itrConfig itr) oldRes writeItr itr itrResponse newRes where - relyOnRequest :: STM () + relyOnRequest ∷ STM () relyOnRequest - = do status <- readItr itr itrResponse resStatus - req <- readItr itr itrRequest fromJust + = do status ← readItr itr itrResponse resStatus + req ← readItr itr itrRequest fromJust let reqVer = reqVersion req - canHaveBody = if reqMethod req == HEAD then + canHaveBody = if reqMethod req ≡ HEAD then False else - not (isInformational status || - status == NoContent || - status == ResetContent || - status == NotModified ) + not (isInformational status ∨ + status ≡ NoContent ∨ + status ≡ ResetContent ∨ + status ≡ NotModified ) - updateRes $! deleteHeader (C8.pack "Content-Length") - updateRes $! deleteHeader (C8.pack "Transfer-Encoding") + updateRes $ deleteHeader "Content-Length" + updateRes $ deleteHeader "Transfer-Encoding" - cType <- readHeader (C8.pack "Content-Type") - when (cType == Nothing) - $ updateRes $ setHeader (C8.pack "Content-Type") defaultPageContentType + cType ← readHeader "Content-Type" + when (cType ≡ Nothing) + $ updateRes $ setHeader "Content-Type" defaultPageContentType if canHaveBody then - when (reqVer == HttpVersion 1 1) - $ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked") + when (reqVer ≡ HttpVersion 1 1) + $ do updateRes $ setHeader "Transfer-Encoding" "chunked" writeItr itr itrWillChunkBody True else -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す when (reqMethod req /= HEAD) - $ do updateRes $! deleteHeader (C8.pack "Content-Type") - updateRes $! deleteHeader (C8.pack "Etag") - updateRes $! deleteHeader (C8.pack "Last-Modified") + $ do updateRes $ deleteHeader "Content-Type" + updateRes $ deleteHeader "Etag" + updateRes $ deleteHeader "Last-Modified" - conn <- readHeader (C8.pack "Connection") + conn ← readHeader "Connection" case conn of - Nothing -> return () - Just value -> when (value `noCaseEq` C8.pack "close") + Nothing → return () + Just value → when (A.toCIAscii value ≡ "close") $ writeItr itr itrWillClose True - willClose <- readItr itr itrWillClose id + willClose ← readItr itr itrWillClose id when willClose - $ updateRes $! setHeader (C8.pack "Connection") (C8.pack "close") + $ updateRes $ setHeader "Connection" "close" - when (reqMethod req == HEAD || not canHaveBody) + when (reqMethod req ≡ HEAD ∨ not canHaveBody) $ writeTVar (itrWillDiscardBody itr) True - readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString) - readHeader !name - = readItr itr itrResponse $ getHeader name - - updateRes :: (Response -> Response) -> STM () - updateRes !updator - = updateItr itr itrResponse updator + readHeader ∷ CIAscii → STM (Maybe Ascii) + readHeader = readItr itr itrResponse ∘ getHeader + updateRes ∷ (Response → Response) → STM () + updateRes = updateItr itr itrResponse -completeUnconditionalHeaders :: Config -> Response -> IO Response -completeUnconditionalHeaders !conf !res - = compServer res >>= compDate +completeUnconditionalHeaders ∷ Config → Response → IO Response +completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer where compServer res' - = case getHeader (C8.pack "Server") res' of - Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res' - Just _ -> return res' + = case getHeader "Server" res' of + Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res' + Just _ → return res' compDate res' - = case getHeader (C8.pack "Date") res' of - Nothing -> do date <- getCurrentDate - return $ setHeader (C8.pack "Date") date res' - Just _ -> return res' - - -cache :: IORef (UTCTime, Strict.ByteString) -cache = unsafePerformIO $ - newIORef (UTCTime (ModifiedJulianDay 0) 0, undefined) -{-# NOINLINE cache #-} - -getCurrentDate :: IO Strict.ByteString -getCurrentDate = do now <- getCurrentTime - (cachedTime, cachedStr) <- readIORef cache - - if now `mostlyEq` cachedTime then - return cachedStr - else - do let dateStr = C8.pack $ HTTP.format now - writeIORef cache (now, dateStr) - return dateStr - where - mostlyEq :: UTCTime -> UTCTime -> Bool - mostlyEq a b - = (utctDay a == utctDay b) - && - (fromEnum (utctDayTime a) == fromEnum (utctDayTime b)) + = case getHeader "Date" res' of + Nothing → do date ← getCurrentDate + return $ setHeader "Date" date res' + Just _ → return res' + +getCurrentDate ∷ IO Ascii +getCurrentDate = HTTP.format <$> getCurrentTime diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index adf8505..872a52f 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DeriveDataTypeable + , OverloadedStrings , UnboxedTuples , UnicodeSyntax + , ViewPatterns #-} {-# OPTIONS_HADDOCK prune #-} @@ -9,6 +11,7 @@ module Network.HTTP.Lucu.Response ( StatusCode(..) , Response(..) + , printStatusCode , hPutResponse , isInformational , isSuccessful @@ -19,14 +22,17 @@ module Network.HTTP.Lucu.Response , statusCode ) where - +import Data.Ascii (Ascii) +import qualified Data.Ascii as A import qualified Data.ByteString as Strict (ByteString) import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import Data.Typeable -import Network.HTTP.Lucu.Format -import Network.HTTP.Lucu.HandleLike -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion +import Data.Monoid.Unicode +import Data.Typeable +import Network.HTTP.Lucu.Format +import Network.HTTP.Lucu.HandleLike +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.HttpVersion +import Prelude.Unicode -- |This is the definition of HTTP status code. -- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named statuses @@ -82,126 +88,124 @@ data StatusCode = Continue | GatewayTimeout | HttpVersionNotSupported | InsufficientStorage - deriving (Typeable, Eq) - -instance Show StatusCode where - show sc = case statusCode sc of - (# num, msg #) - -> (fmtDec 3 num) ++ " " ++ C8.unpack msg + deriving (Eq, Show, Typeable) +-- |Convert a 'StatusCode' to 'Ascii'. +printStatusCode ∷ StatusCode → Ascii +printStatusCode (statusCode → (# num, msg #)) + = A.fromAsciiBuilder $ + ( fmtDec 3 num ⊕ + A.toAsciiBuilder " " ⊕ + A.toAsciiBuilder msg + ) data Response = Response { - resVersion :: !HttpVersion - , resStatus :: !StatusCode - , resHeaders :: !Headers + resVersion ∷ !HttpVersion + , resStatus ∷ !StatusCode + , resHeaders ∷ !Headers } deriving (Show, Eq) - instance HasHeaders Response where getHeaders = resHeaders setHeaders res hdr = res { resHeaders = hdr } - -hPutResponse :: HandleLike h => h -> Response -> IO () +hPutResponse ∷ HandleLike h => h → Response → IO () hPutResponse h res - = h `seq` res `seq` - do hPutHttpVersion h (resVersion res) + = do hPutHttpVersion h (resVersion res) hPutChar h ' ' hPutStatus h (resStatus res) - hPutBS h (C8.pack "\r\n") + hPutBS h "\r\n" hPutHeaders h (resHeaders res) -hPutStatus :: HandleLike h => h -> StatusCode -> IO () +hPutStatus ∷ HandleLike h => h → StatusCode → IO () hPutStatus h sc - = h `seq` sc `seq` - case statusCode sc of + = case statusCode sc of (# num, msg #) - -> do hPutStr h (fmtDec 3 num) - hPutChar h ' ' - hPutBS h msg - + → do hPutStr h (fmtDec 3 num) + hPutChar h ' ' + hPutBS h msg -- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@. -isInformational :: StatusCode -> Bool +isInformational ∷ StatusCode → Bool isInformational = doesMeet (< 200) -- |@'isSuccessful' sc@ is 'Prelude.True' iff @200 <= sc < 300@. -isSuccessful :: StatusCode -> Bool -isSuccessful = doesMeet (\ n -> n >= 200 && n < 300) +isSuccessful ∷ StatusCode → Bool +isSuccessful = doesMeet (\ n → n ≥ 200 ∧ n < 300) -- |@'isRedirection' sc@ is 'Prelude.True' iff @300 <= sc < 400@. -isRedirection :: StatusCode -> Bool -isRedirection = doesMeet (\ n -> n >= 300 && n < 400) +isRedirection ∷ StatusCode → Bool +isRedirection = doesMeet (\ n → n ≥ 300 ∧ n < 400) -- |@'isError' sc@ is 'Prelude.True' iff @400 <= sc@ -isError :: StatusCode -> Bool -isError = doesMeet (>= 400) +isError ∷ StatusCode → Bool +isError = doesMeet (≥ 400) -- |@'isClientError' sc@ is 'Prelude.True' iff @400 <= sc < 500@. -isClientError :: StatusCode -> Bool -isClientError = doesMeet (\ n -> n >= 400 && n < 500) +isClientError ∷ StatusCode → Bool +isClientError = doesMeet (\ n → n ≥ 400 ∧ n < 500) -- |@'isServerError' sc@ is 'Prelude.True' iff @500 <= sc@. -isServerError :: StatusCode -> Bool -isServerError = doesMeet (>= 500) +isServerError ∷ StatusCode → Bool +isServerError = doesMeet (≥ 500) -doesMeet :: (Int -> Bool) -> StatusCode -> Bool +doesMeet ∷ (Int → Bool) → StatusCode → Bool doesMeet p sc = case statusCode sc of - (# num, _ #) -> p num + (# num, _ #) → p num -- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual -- representation of @sc@. -statusCode :: StatusCode -> (# Int, Strict.ByteString #) - -statusCode Continue = (# 100, C8.pack "Continue" #) -statusCode SwitchingProtocols = (# 101, C8.pack "Switching Protocols" #) -statusCode Processing = (# 102, C8.pack "Processing" #) - -statusCode Ok = (# 200, C8.pack "OK" #) -statusCode Created = (# 201, C8.pack "Created" #) -statusCode Accepted = (# 202, C8.pack "Accepted" #) -statusCode NonAuthoritativeInformation = (# 203, C8.pack "Non Authoritative Information" #) -statusCode NoContent = (# 204, C8.pack "No Content" #) -statusCode ResetContent = (# 205, C8.pack "Reset Content" #) -statusCode PartialContent = (# 206, C8.pack "Partial Content" #) -statusCode MultiStatus = (# 207, C8.pack "Multi Status" #) - -statusCode MultipleChoices = (# 300, C8.pack "Multiple Choices" #) -statusCode MovedPermanently = (# 301, C8.pack "Moved Permanently" #) -statusCode Found = (# 302, C8.pack "Found" #) -statusCode SeeOther = (# 303, C8.pack "See Other" #) -statusCode NotModified = (# 304, C8.pack "Not Modified" #) -statusCode UseProxy = (# 305, C8.pack "Use Proxy" #) -statusCode TemporaryRedirect = (# 306, C8.pack "Temporary Redirect" #) - -statusCode BadRequest = (# 400, C8.pack "Bad Request" #) -statusCode Unauthorized = (# 401, C8.pack "Unauthorized" #) -statusCode PaymentRequired = (# 402, C8.pack "Payment Required" #) -statusCode Forbidden = (# 403, C8.pack "Forbidden" #) -statusCode NotFound = (# 404, C8.pack "Not Found" #) -statusCode MethodNotAllowed = (# 405, C8.pack "Method Not Allowed" #) -statusCode NotAcceptable = (# 406, C8.pack "Not Acceptable" #) -statusCode ProxyAuthenticationRequired = (# 407, C8.pack "Proxy Authentication Required" #) -statusCode RequestTimeout = (# 408, C8.pack "Request Timeout" #) -statusCode Conflict = (# 409, C8.pack "Conflict" #) -statusCode Gone = (# 410, C8.pack "Gone" #) -statusCode LengthRequired = (# 411, C8.pack "Length Required" #) -statusCode PreconditionFailed = (# 412, C8.pack "Precondition Failed" #) -statusCode RequestEntityTooLarge = (# 413, C8.pack "Request Entity Too Large" #) -statusCode RequestURITooLarge = (# 414, C8.pack "Request URI Too Large" #) -statusCode UnsupportedMediaType = (# 415, C8.pack "Unsupported Media Type" #) -statusCode RequestRangeNotSatisfiable = (# 416, C8.pack "Request Range Not Satisfiable" #) -statusCode ExpectationFailed = (# 417, C8.pack "Expectation Failed" #) -statusCode UnprocessableEntitiy = (# 422, C8.pack "Unprocessable Entity" #) -statusCode Locked = (# 423, C8.pack "Locked" #) -statusCode FailedDependency = (# 424, C8.pack "Failed Dependency" #) - -statusCode InternalServerError = (# 500, C8.pack "Internal Server Error" #) -statusCode NotImplemented = (# 501, C8.pack "Not Implemented" #) -statusCode BadGateway = (# 502, C8.pack "Bad Gateway" #) -statusCode ServiceUnavailable = (# 503, C8.pack "Service Unavailable" #) -statusCode GatewayTimeout = (# 504, C8.pack "Gateway Timeout" #) -statusCode HttpVersionNotSupported = (# 505, C8.pack "HTTP Version Not Supported" #) -statusCode InsufficientStorage = (# 507, C8.pack "Insufficient Storage" #) \ No newline at end of file +statusCode ∷ StatusCode → (# Int, Ascii #) + +statusCode Continue = (# 100, "Continue" #) +statusCode SwitchingProtocols = (# 101, "Switching Protocols" #) +statusCode Processing = (# 102, "Processing" #) + +statusCode Ok = (# 200, "OK" #) +statusCode Created = (# 201, "Created" #) +statusCode Accepted = (# 202, "Accepted" #) +statusCode NonAuthoritativeInformation = (# 203, "Non Authoritative Information" #) +statusCode NoContent = (# 204, "No Content" #) +statusCode ResetContent = (# 205, "Reset Content" #) +statusCode PartialContent = (# 206, "Partial Content" #) +statusCode MultiStatus = (# 207, "Multi Status" #) + +statusCode MultipleChoices = (# 300, "Multiple Choices" #) +statusCode MovedPermanently = (# 301, "Moved Permanently" #) +statusCode Found = (# 302, "Found" #) +statusCode SeeOther = (# 303, "See Other" #) +statusCode NotModified = (# 304, "Not Modified" #) +statusCode UseProxy = (# 305, "Use Proxy" #) +statusCode TemporaryRedirect = (# 306, "Temporary Redirect" #) + +statusCode BadRequest = (# 400, "Bad Request" #) +statusCode Unauthorized = (# 401, "Unauthorized" #) +statusCode PaymentRequired = (# 402, "Payment Required" #) +statusCode Forbidden = (# 403, "Forbidden" #) +statusCode NotFound = (# 404, "Not Found" #) +statusCode MethodNotAllowed = (# 405, "Method Not Allowed" #) +statusCode NotAcceptable = (# 406, "Not Acceptable" #) +statusCode ProxyAuthenticationRequired = (# 407, "Proxy Authentication Required" #) +statusCode RequestTimeout = (# 408, "Request Timeout" #) +statusCode Conflict = (# 409, "Conflict" #) +statusCode Gone = (# 410, "Gone" #) +statusCode LengthRequired = (# 411, "Length Required" #) +statusCode PreconditionFailed = (# 412, "Precondition Failed" #) +statusCode RequestEntityTooLarge = (# 413, "Request Entity Too Large" #) +statusCode RequestURITooLarge = (# 414, "Request URI Too Large" #) +statusCode UnsupportedMediaType = (# 415, "Unsupported Media Type" #) +statusCode RequestRangeNotSatisfiable = (# 416, "Request Range Not Satisfiable" #) +statusCode ExpectationFailed = (# 417, "Expectation Failed" #) +statusCode UnprocessableEntitiy = (# 422, "Unprocessable Entity" #) +statusCode Locked = (# 423, "Locked" #) +statusCode FailedDependency = (# 424, "Failed Dependency" #) + +statusCode InternalServerError = (# 500, "Internal Server Error" #) +statusCode NotImplemented = (# 501, "Not Implemented" #) +statusCode BadGateway = (# 502, "Bad Gateway" #) +statusCode ServiceUnavailable = (# 503, "Service Unavailable" #) +statusCode GatewayTimeout = (# 504, "Gateway Timeout" #) +statusCode HttpVersionNotSupported = (# 505, "HTTP Version Not Supported" #) +statusCode InsufficientStorage = (# 507, "Insufficient Storage" #)