+{-# LANGUAGE
+ OverloadedStrings
+ , UnicodeSyntax
+ #-}
-- |Configurations for the Lucu httpd like a port to listen.
module Network.HTTP.Lucu.Config
( 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
-- good idea to use GnomeVFS
-- (<http://developer.gnome.org/doc/API/2.0/gnome-vfs-2.0/>)
-- instead of vanilla FS.
- , cnfExtToMIMEType :: !ExtMap
+ , cnfExtToMIMEType ∷ !ExtMap
}
-- |Configuration record for HTTPS connections.
-- |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 "::"
{-# 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"
+{-# LANGUAGE
+ OverloadedStrings
+ , ScopedTypeVariables
+ , UnboxedTuples
+ , UnicodeSyntax
+ #-}
-- 本當にこんなものを自分で書く必要があったのだらうか。Printf は重いの
-- で駄目だが、それ以外のモジュールを探しても見付からなかった。
-
module Network.HTTP.Lucu.Format
( fmtInt
, 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
{-# LANGUAGE
BangPatterns
+ , OverloadedStrings
, UnicodeSyntax
#-}
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
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
+import Prelude.Unicode
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.")
-- 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
{-# LANGUAGE
DeriveDataTypeable
+ , OverloadedStrings
, UnboxedTuples
, UnicodeSyntax
+ , ViewPatterns
#-}
{-# OPTIONS_HADDOCK prune #-}
module Network.HTTP.Lucu.Response
( StatusCode(..)
, Response(..)
+ , printStatusCode
, hPutResponse
, isInformational
, isSuccessful
, 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
| 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" #)
projects / Lucu.git / commitdiff