import Control.Concurrent.STM
import Control.Exception
import Control.Monad.Trans
-import GHC.Conc (unsafeIOToSTM)
+import Data.ByteString.Base (ByteString)
import Data.Dynamic
+import GHC.Conc (unsafeIOToSTM)
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.Headers
-- > abort MovedPermanently
-- > [("Location", "http://example.net/")]
-- > (Just "It has been moved to example.net")
-abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
+abort :: MonadIO m => StatusCode -> [ (ByteString, ByteString) ] -> Maybe String -> m a
abort status headers msg
= status `seq` headers `seq` msg `seq`
- let abo = Abortion status headers msg
+ let abo = Abortion status (toHeaders headers) msg
exc = DynException (toDyn abo)
in
liftIO $ throwIO exc
-- |Computation of @'abortSTM' status headers msg@ just computes
-- 'abort' in a 'Control.Monad.STM.STM' monad.
-abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
+abortSTM :: StatusCode -> [ (ByteString, ByteString) ] -> Maybe String -> STM a
abortSTM status headers msg
= status `seq` headers `seq` msg `seq`
unsafeIOToSTM $! abort status headers msg
-- | Computation of @'abortA' -< (status, (headers, msg))@ just
-- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'.
-abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
+abortA :: ArrowIO a => a (StatusCode, ([ (ByteString, ByteString) ], Maybe String)) c
abortA
= arrIO3 abort
Nothing
-> let res' = res { resStatus = aboStatus abo }
res'' = foldl (.) id [setHeader name value
- | (name, value) <- aboHeaders abo]
+ | (name, value) <- fromHeaders $ aboHeaders abo]
$ res'
in
getDefaultPage conf reqM res''
)
where
+import Data.ByteString.Base (ByteString)
+import qualified Data.ByteString.Char8 as C8
import Network
import Network.BSD
import Network.HTTP.Lucu.MIMEType.Guess
-- '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 :: !String
+ cnfServerSoftware :: !ByteString
-- |The host name of the server. This value will be used in
-- built-in pages like \"404 Not Found\".
- , cnfServerHost :: !HostName
+ , cnfServerHost :: !ByteString
-- |A port ID to listen to HTTP clients.
, cnfServerPort :: !PortID
-- |The maximum number of requests to accept in one connection
-- 'cnfServerPort'.
defaultConfig :: Config
defaultConfig = Config {
- cnfServerSoftware = "Lucu/1.0"
- , cnfServerHost = unsafePerformIO getHostName
+ cnfServerSoftware = C8.pack "Lucu/1.0"
+ , cnfServerHost = C8.pack (unsafePerformIO getHostName)
, cnfServerPort = Service "http"
, cnfMaxPipelineDepth = 100
, cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB
import Control.Arrow.ArrowList
import Control.Concurrent.STM
import Control.Monad
-import qualified Data.ByteString.Lazy.Char8 as B
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Maybe
import Network
import Network.HTTP.Lucu.Config
-- Content-Type が正しくなければ補完できない。
res <- readItr itr itrResponse id
- when (getHeader "Content-Type" res == Just defaultPageContentType)
+ when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType)
$ do reqM <- readItr itr itrRequest id
let conf = itrConfig itr
- page = B.pack $ getDefaultPage conf reqM res
+ page = L8.pack $ getDefaultPage conf reqM res
writeTVar (itrBodyToSend itr)
$ page
mkDefaultPage conf status msgA
= conf `seq` status `seq` msgA `seq`
let (# sCode, sMsg #) = statusCode status
- sig = cnfServerSoftware conf
+ sig = C8.unpack (cnfServerSoftware conf)
++ " at "
- ++ cnfServerHost conf
+ ++ C8.unpack (cnfServerHost conf)
++ ( case cnfServerPort conf of
Service serv -> ", service " ++ serv
PortNumber num -> ", port " ++ show num
uriPath uri
loc :: String
- loc = fromJust $! getHeader "Location" res
+ loc = C8.unpack $! fromJust $! getHeader (C8.pack "Location") res
{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-}
\ No newline at end of file
module Network.HTTP.Lucu.Headers
( Headers
, HasHeaders(..)
+
+ , noCaseCmp
+ , noCaseEq
+
, emptyHeaders
+ , toHeaders
+ , fromHeaders
+
, headersP
, hPutHeaders
)
where
+import Data.ByteString.Base (ByteString, toForeignPtr, w2c, inlinePerformIO)
+import qualified Data.ByteString.Char8 as C8
import Data.Char
import Data.List
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Word
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import Foreign.Storable
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.Utils
import System.IO
-type Headers = [ (String, String) ]
+type Headers = Map NCBS ByteString
+newtype NCBS = NCBS ByteString
+
+toNCBS :: ByteString -> NCBS
+toNCBS = NCBS
+{-# INLINE toNCBS #-}
+
+fromNCBS :: NCBS -> ByteString
+fromNCBS (NCBS x) = x
+{-# INLINE fromNCBS #-}
+
+instance Eq NCBS where
+ (NCBS a) == (NCBS b) = a == b
+
+instance Ord NCBS where
+ (NCBS a) `compare` (NCBS b) = a `noCaseCmp` b
+
+instance Show NCBS where
+ show (NCBS x) = show x
+
+noCaseCmp :: ByteString -> ByteString -> Ordering
+noCaseCmp a b = toForeignPtr a `cmp` toForeignPtr b
+ where
+ cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Ordering
+ cmp (x1, s1, l1) (x2, s2, l2)
+ | l1 == 0 && l2 == 0 = EQ
+ | x1 == x2 && s1 == s2 && l1 == l2 = EQ
+ | otherwise
+ = inlinePerformIO $
+ withForeignPtr x1 $ \ p1 ->
+ withForeignPtr x2 $ \ p2 ->
+ noCaseCmp' (p1 `plusPtr` s1) l1 (p2 `plusPtr` s2) l2
+{-# INLINE noCaseCmp #-}
+
+-- もし先頭の文字列が等しければ、短い方が小さい。
+noCaseCmp' :: Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO Ordering
+noCaseCmp' p1 l1 p2 l2
+ | l1 == 0 && l2 == 0 = return EQ
+ | l1 == 0 && l1 /= 0 = return LT
+ | l1 /= 0 && l2 == 0 = return GT
+ | otherwise
+ = do c1 <- peek p1
+ c2 <- peek p2
+ case toLower (w2c c1) `compare` toLower (w2c c2) of
+ EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1)
+ x -> return x
+
+
+noCaseEq :: ByteString -> ByteString -> Bool
+noCaseEq a b = toForeignPtr a `cmp` toForeignPtr b
+ where
+ cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Bool
+ cmp (x1, s1, l1) (x2, s2, l2)
+ | l1 /= l2 = False
+ | l1 == 0 && l2 == 0 = True
+ | x1 == x2 && s1 == s2 && l1 == l2 = True
+ | otherwise
+ = inlinePerformIO $
+ withForeignPtr x1 $ \ p1 ->
+ withForeignPtr x2 $ \ p2 ->
+ noCaseEq' (p1 `plusPtr` s1) (p2 `plusPtr` s2) l1
+
+
+noCaseEq' :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool
+noCaseEq' p1 p2 l
+ | l == 0 = return True
+ | otherwise
+ = do c1 <- peek p1
+ c2 <- peek p2
+ if toLower (w2c c1) == toLower (w2c c2) then
+ noCaseEq' (p1 `plusPtr` 1) (p2 `plusPtr` 1) (l - 1)
+ else
+ return False
+
class HasHeaders a where
getHeaders :: a -> Headers
setHeaders :: a -> Headers -> a
- getHeader :: String -> a -> Maybe String
+ getHeader :: ByteString -> a -> Maybe ByteString
getHeader key a
= key `seq` a `seq`
- fmap snd $ find (noCaseEq' key . fst) (getHeaders a)
+ M.lookup (toNCBS key) (getHeaders a)
- deleteHeader :: String -> a -> a
+ deleteHeader :: ByteString -> a -> a
deleteHeader key a
= key `seq` a `seq`
- setHeaders a $ filter (not . noCaseEq' key . fst) (getHeaders a)
-
- addHeader :: String -> String -> a -> a
- addHeader key val a
- = key `seq` val `seq` a `seq`
- setHeaders a $ (getHeaders a) ++ [(key, val)]
+ setHeaders a $ M.delete (toNCBS key) (getHeaders a)
- setHeader :: String -> String -> a -> a
+ setHeader :: ByteString -> ByteString -> a -> a
setHeader key val a
= key `seq` val `seq` a `seq`
- let list = getHeaders a
- deleted = filter (not . noCaseEq' key . fst) list
- added = deleted ++ [(key, val)]
- in
- setHeaders a added
+ setHeaders a $ M.insert (toNCBS key) val (getHeaders a)
+
emptyHeaders :: Headers
-emptyHeaders = []
+emptyHeaders = M.empty
+
+
+toHeaders :: [(ByteString, ByteString)] -> Headers
+toHeaders xs = M.fromList [(toNCBS a, b) | (a, b) <- xs]
+
+
+fromHeaders :: Headers -> [(ByteString, ByteString)]
+fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs]
{-
headersP :: Parser Headers
headersP = do xs <- many header
crlf
- return xs
+ return (M.fromList xs)
where
- header :: Parser (String, String)
+ header :: Parser (NCBS, ByteString)
header = do name <- token
char ':'
-- FIXME: これは多少インチキだが、RFC 2616 のこの部分
contents <- many (lws <|> many1 text)
crlf
let value = foldr (++) "" contents
- return (name, normalize value)
+ norm = normalize value
+ return (toNCBS $ C8.pack name, C8.pack norm)
normalize :: String -> String
normalize = trimBody . trim isWhiteSpace
hPutHeaders :: Handle -> Headers -> IO ()
hPutHeaders h hds
= h `seq` hds `seq`
- mapM_ putH hds >> hPutStr h "\r\n"
+ mapM_ putH (M.toList hds) >> hPutStr h "\r\n"
where
- putH :: (String, String) -> IO ()
+ putH :: (NCBS, ByteString) -> IO ()
putH (name, value)
= name `seq` value `seq`
- do hPutStr h name
- hPutStr h ": "
- hPutStr h value
- hPutStr h "\r\n"
+ do C8.hPutStr h (fromNCBS name)
+ C8.hPutStr h (C8.pack ": ")
+ C8.hPutStr h value
+ C8.hPutStr h (C8.pack "\r\n")
where
import Control.Concurrent.STM
-import qualified Data.ByteString.Lazy.Char8 as B
-import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.ByteString.Base (ByteString, LazyByteString)
+import Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.Sequence as S
import Data.Sequence (Seq)
import Network.Socket
import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
, itrReqChunkIsOver :: !(TVar Bool)
, itrReqBodyWanted :: !(TVar (Maybe Int))
, itrReqBodyWasteAll :: !(TVar Bool)
- , itrReceivedBody :: !(TVar ByteString) -- Resource が受領した部分は削除される
+ , itrReceivedBody :: !(TVar LazyByteString) -- Resource が受領した部分は削除される
, itrWillReceiveBody :: !(TVar Bool)
, itrWillChunkBody :: !(TVar Bool)
, itrWillDiscardBody :: !(TVar Bool)
, itrWillClose :: !(TVar Bool)
- , itrBodyToSend :: !(TVar ByteString)
+ , itrBodyToSend :: !(TVar LazyByteString)
, itrBodyIsNull :: !(TVar Bool)
, itrState :: !(TVar InteractionState)
newInteractionQueue = newTVarIO S.empty
-defaultPageContentType :: String
-defaultPageContentType = "application/xhtml+xml"
+defaultPageContentType :: ByteString
+defaultPageContentType = C8.pack "application/xhtml+xml"
newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction
responce <- newTVarIO $ Response {
resVersion = HttpVersion 1 1
, resStatus = Ok
- , resHeaders = [("Content-Type", defaultPageContentType)]
+ , resHeaders = toHeaders [(C8.pack "Content-Type", defaultPageContentType)]
}
requestHasBody <- newTVarIO False
reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた
reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
- receivedBody <- newTVarIO B.empty
+ receivedBody <- newTVarIO L8.empty
willReceiveBody <- newTVarIO False
willChunkBody <- newTVarIO False
willDiscardBody <- newTVarIO False
willClose <- newTVarIO False
- bodyToSend <- newTVarIO B.empty
+ bodyToSend <- newTVarIO L8.empty
bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
state <- newTVarIO ExaminingRequest
import Control.Concurrent.STM
import Control.Monad
-import Data.Char
+import Data.ByteString.Base (ByteString)
+import qualified Data.ByteString.Char8 as C8
+import Data.IORef
import Data.Maybe
import GHC.Conc (unsafeIOToSTM)
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import System.Time
+import System.IO.Unsafe
{-
$ Just ("The status code is not good for a final status: "
++ show sc)
- when (sc == MethodNotAllowed && getHeader "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 "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.")
status == ResetContent ||
status == NotModified )
- updateRes itr $! deleteHeader "Content-Length"
- updateRes itr $! deleteHeader "Transfer-Encoding"
+ updateRes itr $! deleteHeader (C8.pack "Content-Length")
+ updateRes itr $! deleteHeader (C8.pack "Transfer-Encoding")
- cType <- readHeader itr "Content-Type"
+ cType <- readHeader itr (C8.pack "Content-Type")
when (cType == Nothing)
- $ updateRes itr $ setHeader "Content-Type" defaultPageContentType
+ $ updateRes itr $ setHeader (C8.pack "Content-Type") defaultPageContentType
if canHaveBody then
when (reqVer == HttpVersion 1 1)
- $ do updateRes itr $! setHeader "Transfer-Encoding" "chunked"
+ $ do updateRes itr $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked")
writeItr itr itrWillChunkBody True
else
-- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
when (reqMethod req /= HEAD)
- $ do updateRes itr $! deleteHeader "Content-Type"
- updateRes itr $! deleteHeader "Etag"
- updateRes itr $! deleteHeader "Last-Modified"
-
- conn <- readHeader itr "Connection"
- case fmap (map toLower) conn of
- Just "close" -> writeItr itr itrWillClose True
- _ -> return ()
+ $ do updateRes itr $! deleteHeader (C8.pack "Content-Type")
+ updateRes itr $! deleteHeader (C8.pack "Etag")
+ updateRes itr $! deleteHeader (C8.pack "Last-Modified")
+
+ conn <- readHeader itr (C8.pack "Connection")
+ case conn of
+ Nothing -> return ()
+ Just value -> if value `noCaseEq` C8.pack "close" then
+ writeItr itr itrWillClose True
+ else
+ return ()
willClose <- readItr itr itrWillClose id
when willClose
- $ updateRes itr $! setHeader "Connection" "close"
+ $ updateRes itr $! setHeader (C8.pack "Connection") (C8.pack "close")
when (reqMethod req == HEAD || not canHaveBody)
$ writeTVar (itrWillDiscardBody itr) True
- readHeader :: Interaction -> String -> STM (Maybe String)
+ readHeader :: Interaction -> ByteString -> STM (Maybe ByteString)
readHeader itr name
= itr `seq` name `seq`
readItr itr itrResponse $ getHeader name
return res >>= compServer >>= compDate >>= return
where
compServer res
- = case getHeader "Server" res of
- Nothing -> return $ addHeader "Server" (cnfServerSoftware conf) res
+ = case getHeader (C8.pack "Server") res of
+ Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res
Just _ -> return res
compDate res
- = case getHeader "Date" res of
- Nothing -> do time <- getClockTime
- return $ addHeader "Date" (formatHTTPDateTime time) res
- Just _ -> return res
\ No newline at end of file
+ = case getHeader (C8.pack "Date") res of
+ Nothing -> do date <- getCurrentDate
+ return $ setHeader (C8.pack "Date") date res
+ Just _ -> return res
+
+
+cache :: IORef (ClockTime, ByteString)
+cache = unsafePerformIO $
+ newIORef (TOD 0 0, undefined)
+{-# NOINLINE cache #-}
+
+getCurrentDate :: IO ByteString
+getCurrentDate = do now@(TOD curSec _) <- getClockTime
+ (TOD cachedSec _, cachedStr) <- readIORef cache
+
+ if curSec == cachedSec then
+ return cachedStr
+ else
+ do let dateStr = C8.pack $ formatHTTPDateTime now
+ writeIORef cache (now, dateStr)
+ return dateStr
\ No newline at end of file
import Control.Concurrent.STM
import Control.Monad
+import Data.ByteString.Base (ByteString)
+import qualified Data.ByteString.Char8 as C8
import Data.Char
import Data.Maybe
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.Utils
import Network
import Network.URI
PUT -> writeItr itr itrRequestHasBody True
_ -> setStatus NotImplemented
- mapM_ (preprocessHeader itr) (reqHeaders req)
+ preprocessHeader itr req
where
setStatus :: StatusCode -> STM ()
setStatus status
Just n -> Just $ ":" ++ show n
Nothing -> Nothing
case portStr of
- Just str -> updateAuthority host str
+ Just str -> updateAuthority host (C8.pack str)
-- FIXME: このエラーの原因は、listen してゐるソ
-- ケットが INET でない故にポート番號が分からな
-- い事だが、その事をどうにかして通知した方が良
-- いと思ふ。stderr？
Nothing -> setStatus InternalServerError
else
- do case getHeader "Host" req of
+ do case getHeader (C8.pack "Host") req of
Just str -> let (host, portStr) = parseHost str
in updateAuthority host portStr
Nothing -> setStatus BadRequest
- parseHost :: String -> (String, String)
- parseHost = break (== ':')
+ parseHost :: ByteString -> (ByteString, ByteString)
+ parseHost = C8.break (== ':')
- updateAuthority :: String -> String -> STM ()
+ updateAuthority :: ByteString -> ByteString -> STM ()
updateAuthority host portStr
= host `seq` portStr `seq`
updateItr itr itrRequest
in uri {
uriAuthority = Just URIAuth {
uriUserInfo = ""
- , uriRegName = host
- , uriPort = portStr
+ , uriRegName = C8.unpack host
+ , uriPort = C8.unpack portStr
}
}
}
- preprocessHeader :: Interaction -> (String, String) -> STM ()
- preprocessHeader itr (name, value)
- = itr `seq` name `seq` value `seq`
- case map toLower name of
-
- "expect"
- -> if value `noCaseEq'` "100-continue" then
- writeItr itr itrExpectedContinue True
- else
- setStatus ExpectationFailed
-
- "transfer-encoding"
- -> case map toLower value of
- "identity" -> return ()
- "chunked" -> writeItr itr itrRequestIsChunked True
- _ -> setStatus NotImplemented
-
- "content-length"
- -> if all isDigit value then
- do let len = read value
- writeItr itr itrReqChunkLength $ Just len
- writeItr itr itrReqChunkRemaining $ Just len
- else
- setStatus BadRequest
-
- "connection"
- -> case map toLower value of
- "close" -> writeItr itr itrWillClose True
- _ -> return ()
-
- _ -> return ()
\ No newline at end of file
+ preprocessHeader :: Interaction -> Request -> STM ()
+ preprocessHeader itr req
+ = itr `seq` req `seq`
+ do case getHeader (C8.pack "Expect") req of
+ Nothing -> return ()
+ Just value -> if value `noCaseEq` C8.pack "100-continue" then
+ writeItr itr itrExpectedContinue True
+ else
+ setStatus ExpectationFailed
+
+ case getHeader (C8.pack "Transfer-Encoding") req of
+ Nothing -> return ()
+ Just value -> if value `noCaseEq` C8.pack "identity" then
+ return ()
+ else
+ if value `noCaseEq` C8.pack "chunked" then
+ writeItr itr itrRequestIsChunked True
+ else
+ setStatus NotImplemented
+
+ case getHeader (C8.pack "Content-Length") req of
+ Nothing -> return ()
+ Just value -> if C8.all isDigit value then
+ do let Just (len, _) = C8.readInt value
+ writeItr itr itrReqChunkLength $ Just len
+ writeItr itr itrReqChunkRemaining $ Just len
+ else
+ setStatus BadRequest
+
+ case getHeader (C8.pack "Connection") req of
+ Nothing -> return ()
+ Just value -> if value `noCaseEq` C8.pack "close" then
+ writeItr itr itrWillClose True
+ else
+ return ()
where
import Control.Monad
+import Data.ByteString.Base (LazyByteString)
import Network.HTTP.Lucu.Format
import Network.HTTP.Lucu.Parser
import System.Time
-- ...but currently this function only supports the RFC 1123
-- format. This is a violation of RFC 2616 so this should be fixed
-- later. What a bother!
-parseHTTPDateTime :: String -> Maybe ClockTime
+parseHTTPDateTime :: LazyByteString -> Maybe ClockTime
parseHTTPDateTime src
- = case parseStr httpDateTime src of
+ = case parse httpDateTime src of
(# Success ct, _ #) -> Just ct
(# _ , _ #) -> Nothing
import Control.Concurrent.STM
import Control.Monad.Reader
import Data.Bits
-import Data.ByteString.Base (LazyByteString)
-import qualified Data.ByteString.Lazy.Char8 as B
+import Data.ByteString.Base (ByteString, LazyByteString(..))
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy.Char8 as L8
import Data.List
import Data.Maybe
import Network.HTTP.Lucu.Abortion
-- case-insensitive. Note that this action is not intended to be used
-- so frequently: there should be actions like 'getContentType' for
-- every common headers.
-getHeader :: String -> Resource (Maybe String)
+getHeader :: ByteString -> Resource (Maybe ByteString)
getHeader name = name `seq`
do req <- getRequest
return $! H.getHeader name req
-- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
-- header \"Accept\".
getAccept :: Resource [MIMEType]
-getAccept = do acceptM <- getHeader "Accept"
+getAccept = do acceptM <- getHeader (C8.pack "Accept")
case acceptM of
Nothing
-> return []
Just accept
- -> case parseStr mimeTypeListP accept of
+ -> case parse mimeTypeListP (LPS [accept]) of
(# Success xs, _ #) -> return xs
(# _ , _ #) -> abort BadRequest []
- (Just $ "Unparsable Accept: " ++ accept)
+ (Just $ "Unparsable Accept: " ++ C8.unpack accept)
-- |Get a list of @(contentCoding, qvalue)@ enumerated on header
-- \"Accept-Encoding\". The list is sorted in descending order by
-- qvalue.
getAcceptEncoding :: Resource [(String, Maybe Double)]
getAcceptEncoding
- = do accEncM <- getHeader "Accept-Encoding"
+ = do accEncM <- getHeader (C8.pack "Accept-Encoding")
case accEncM of
Nothing
-- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
case ver of
HttpVersion 1 0 -> return [("identity", Nothing)]
HttpVersion 1 1 -> return [("*" , Nothing)]
- Just ""
- -- identity のみが許される。
- -> return [("identity", Nothing)]
- Just accEnc
- -> case parseStr acceptEncodingListP accEnc of
- (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
- (# _ , _ #) -> abort BadRequest []
- (Just $ "Unparsable Accept-Encoding: " ++ accEnc)
+ Just value
+ -> if C8.null value then
+ -- identity のみが許される。
+ return [("identity", Nothing)]
+ else
+ case parse acceptEncodingListP (LPS [value]) of
+ (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
+ (# _ , _ #) -> abort BadRequest []
+ (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value)
-- |Check whether a given content-coding is acceptable.
isEncodingAcceptable :: String -> Resource Bool
isEncodingAcceptable coding
= do accList <- getAcceptEncoding
return (flip any accList $ \ (c, q) ->
- (c == "*" || c `noCaseEq` coding) && q /= Just 0)
+ (c == "*" || C8.pack c `H.noCaseEq` C8.pack coding) && q /= Just 0)
-- |Get the header \"Content-Type\" as
-- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
getContentType :: Resource (Maybe MIMEType)
getContentType
- = do cTypeM <- getHeader "Content-Type"
+ = do cTypeM <- getHeader (C8.pack "Content-Type")
case cTypeM of
Nothing
-> return Nothing
Just cType
- -> case parseStr mimeTypeP cType of
+ -> case parse mimeTypeP (LPS [cType]) of
(# Success t, _ #) -> return $ Just t
(# _ , _ #) -> abort BadRequest []
- (Just $ "Unparsable Content-Type: " ++ cType)
+ (Just $ "Unparsable Content-Type: " ++ C8.unpack cType)
{- ExaminingRequest 時に使用するアクション群 -}
method <- getMethod
when (method == GET || method == HEAD)
- $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp
+ $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
when (method == POST)
$ abort InternalServerError []
(Just "Illegal computation of foundEntity for POST request.")
method <- getMethod
when (method == GET || method == HEAD)
- $ setHeader' "ETag" $! show tag
+ $ setHeader' (C8.pack "ETag") (C8.pack $ show tag)
when (method == POST)
$ abort InternalServerError []
(Just "Illegal computation of foundETag for POST request.")
-- If-Match があればそれを見る。
- ifMatch <- getHeader "If-Match"
+ ifMatch <- getHeader (C8.pack "If-Match")
case ifMatch of
- Nothing -> return ()
- Just "*" -> return ()
- Just list -> case parseStr eTagListP list of
- (# Success tags, _ #)
- -- tags の中に一致するものが無ければ
- -- PreconditionFailed で終了。
- -> when (not $ any (== tag) tags)
- $ abort PreconditionFailed []
- $! Just ("The entity tag doesn't match: " ++ list)
- (# _, _ #)
- -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch)
+ Nothing -> return ()
+ Just value -> if value == C8.pack "*" then
+ return ()
+ else
+ case parse eTagListP (LPS [value]) of
+ (# Success tags, _ #)
+ -- tags の中に一致するものが無ければ
+ -- PreconditionFailed で終了。
+ -> when (not $ any (== tag) tags)
+ $ abort PreconditionFailed []
+ $! Just ("The entity tag doesn't match: " ++ C8.unpack value)
+ (# _, _ #)
+ -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ C8.unpack value)
let statusForNoneMatch = if method == GET || method == HEAD then
NotModified
PreconditionFailed
-- If-None-Match があればそれを見る。
- ifNoneMatch <- getHeader "If-None-Match"
+ ifNoneMatch <- getHeader (C8.pack "If-None-Match")
case ifNoneMatch of
- Nothing -> return ()
- Just "*" -> abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
- Just list -> case parseStr eTagListP list of
- (# Success tags, _ #)
- -> when (any (== tag) tags)
- $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ list)
- (# _, _ #)
- -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list)
+ Nothing -> return ()
+ Just value -> if value == C8.pack "*" then
+ abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
+ else
+ case parse eTagListP (LPS [value]) of
+ (# Success tags, _ #)
+ -> when (any (== tag) tags)
+ $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value)
+ (# _, _ #)
+ -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ C8.unpack value)
driftTo GettingBody
method <- getMethod
when (method == GET || method == HEAD)
- $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp
+ $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
when (method == POST)
$ abort InternalServerError []
(Just "Illegal computation of foundTimeStamp for POST request.")
PreconditionFailed
-- If-Modified-Since があればそれを見る。
- ifModSince <- getHeader "If-Modified-Since"
+ ifModSince <- getHeader (C8.pack "If-Modified-Since")
case ifModSince of
- Just str -> case parseHTTPDateTime str of
+ Just str -> case parseHTTPDateTime (LPS [str]) of
Just lastTime
-> when (timeStamp <= lastTime)
$ abort statusForIfModSince []
- $! Just ("The entity has not been modified since " ++ str)
+ $! Just ("The entity has not been modified since " ++ C8.unpack str)
Nothing
-> return () -- 不正な時刻は無視
Nothing -> return ()
-- If-Unmodified-Since があればそれを見る。
- ifUnmodSince <- getHeader "If-Unmodified-Since"
+ ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
case ifUnmodSince of
- Just str -> case parseHTTPDateTime str of
+ Just str -> case parseHTTPDateTime (LPS [str]) of
Just lastTime
-> when (timeStamp > lastTime)
$ abort PreconditionFailed []
- $! Just ("The entity has not been modified since " ++ str)
+ $! Just ("The entity has not been modified since " ++ C8.unpack str)
Nothing
-> return () -- 不正な時刻は無視
Nothing -> return ()
-- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
-- If-Match: 條件も滿たさない。
- ifMatch <- getHeader "If-Match"
+ ifMatch <- getHeader (C8.pack "If-Match")
when (ifMatch /= Nothing)
$ abort PreconditionFailed [] msgM
-- use it whenever possible.
input :: Int -> Resource String
input limit = limit `seq`
- inputLBS limit >>= return . B.unpack
+ inputLBS limit >>= return . L8.unpack
-- | This is mostly the same as 'input' but is more
askForInput itr
else
do driftTo DecidingHeader
- return B.empty
+ return L8.empty
return chunk
where
askForInput :: Interaction -> Resource LazyByteString
chunk <- liftIO $! atomically
$! do chunk <- readItr itr itrReceivedBody id
chunkIsOver <- readItr itr itrReqChunkIsOver id
- if B.length chunk < fromIntegral actualLimit then
+ if L8.length chunk < fromIntegral actualLimit then
-- 要求された量に滿たなくて、まだ殘り
-- があるなら再試行。
unless chunkIsOver
$ tooLarge actualLimit
-- 成功。itr 内にチャンクを置いたままにす
-- るとメモリの無駄になるので除去。
- writeItr itr itrReceivedBody B.empty
+ writeItr itr itrReceivedBody L8.empty
return chunk
driftTo DecidingHeader
return chunk
-- should use it whenever possible.
inputChunk :: Int -> Resource String
inputChunk limit = limit `seq`
- inputChunkLBS limit >>= return . B.unpack
+ inputChunkLBS limit >>= return . L8.unpack
-- | This is mostly the same as 'inputChunk' but is more
askForInput itr
else
do driftTo DecidingHeader
- return B.empty
+ return L8.empty
return chunk
where
askForInput :: Interaction -> Resource LazyByteString
$ do chunk <- readItr itr itrReceivedBody id
-- 要求された量に滿たなくて、まだ殘りがあ
-- るなら再試行。
- when (B.length chunk < fromIntegral actualLimit)
+ when (L8.length chunk < fromIntegral actualLimit)
$ do chunkIsOver <- readItr itr itrReqChunkIsOver id
unless chunkIsOver
$ retry
-- 成功
- writeItr itr itrReceivedBody B.empty
+ writeItr itr itrReceivedBody L8.empty
return chunk
- when (B.null chunk)
+ when (L8.null chunk)
$ driftTo DecidingHeader
return chunk
-- 20 bytes long. In this case the client shall only accept the first
-- 10 bytes of response body and thinks that the residual 10 bytes is
-- a part of header of the next response.
-setHeader :: String -> String -> Resource ()
+setHeader :: ByteString -> ByteString -> Resource ()
setHeader name value
= name `seq` value `seq`
driftTo DecidingHeader >> setHeader' name value
-setHeader' :: String -> String -> Resource ()
+setHeader' :: ByteString -> ByteString -> Resource ()
setHeader' name value
= name `seq` value `seq`
do itr <- getInteraction
-- \"Content-Type\" to @mType@.
setContentType :: MIMEType -> Resource ()
setContentType mType
- = setHeader "Content-Type" $! show mType
+ = setHeader (C8.pack "Content-Type") (C8.pack $ show mType)
-- | Computation of @'setLocation' uri@ sets the response header
-- \"Location\" to @uri@.
setLocation :: URI -> Resource ()
setLocation uri
- = setHeader "Location" $ uriToString id uri $ ""
+ = setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "")
-- |Computation of @'setContentEncoding' codings@ sets the response
-- header \"Content-Encoding\" to @codings@.
let tr = case ver of
HttpVersion 1 0 -> unnormalizeCoding
HttpVersion 1 1 -> id
- setHeader "Content-Encoding" $ joinWith ", " $ map tr codings
+ setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings)
{- DecidingBody 時に使用するアクション群 -}
-- Note that 'outputLBS' is more efficient than 'output' so you should
-- use it whenever possible.
output :: String -> Resource ()
-output str = outputLBS $! B.pack str
+output str = outputLBS $! L8.pack str
{-# INLINE output #-}
-- | This is mostly the same as 'output' but is more efficient.
-- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so
-- you should use it whenever possible.
outputChunk :: String -> Resource ()
-outputChunk str = outputChunkLBS $! B.pack str
+outputChunk str = outputChunkLBS $! L8.pack str
{-# INLINE outputChunk #-}
-- | This is mostly the same as 'outputChunk' but is more efficient.
unless (discardBody)
$ sendChunks str limit
- unless (B.null str)
+ unless (L8.null str)
$ liftIO $ atomically $
writeItr itr itrBodyIsNull False
where
-- チャンクの大きさは Config で制限されてゐる。もし例へば
- -- "/dev/zero" を B.readFile して作った LazyByteString をそのまま
+ -- "/dev/zero" を L8.readFile して作った LazyByteString をそのまま
-- ResponseWriter に渡したりすると大變な事が起こる。何故なら
-- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
-- く爲にチャンクの大きさを測る。
sendChunks :: LazyByteString -> Int -> Resource ()
sendChunks str limit
- | B.null str = return ()
- | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
- itr <- getInteraction
- liftIO $ atomically $
- do buf <- readItr itr itrBodyToSend id
- if B.null buf then
- -- バッファが消化された
- writeItr itr itrBodyToSend chunk
- else
- -- 消化されるのを待つ
- retry
- -- 殘りのチャンクについて繰り返す
- sendChunks remaining limit
+ | L8.null str = return ()
+ | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str
+ itr <- getInteraction
+ liftIO $ atomically $
+ do buf <- readItr itr itrBodyToSend id
+ if L8.null buf then
+ -- バッファが消化された
+ writeItr itr itrBodyToSend chunk
+ else
+ -- 消化されるのを待つ
+ retry
+ -- 殘りのチャンクについて繰り返す
+ sendChunks remaining limit
{-
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
+import qualified Data.ByteString.Char8 as C8
import Data.Dynamic
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.Headers (emptyHeaders, fromHeaders)
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Resource
import Network.HTTP.Lucu.Response
notAllowed :: Resource ()
notAllowed = do setStatus MethodNotAllowed
- setHeader "Allow" $ joinWith ", " allowedMethods
+ setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods)
allowedMethods :: [String]
allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"]
processException :: Exception -> IO ()
processException exc
= do let abo = case exc of
- ErrorCall msg -> Abortion InternalServerError [] $ Just msg
- IOException ioE -> Abortion InternalServerError [] $ Just $ formatIOE ioE
+ ErrorCall msg -> Abortion InternalServerError emptyHeaders $ Just msg
+ IOException ioE -> Abortion InternalServerError emptyHeaders $ Just $ formatIOE ioE
DynException dynE -> case fromDynamic dynE of
Just (abo :: Abortion) -> abo
Nothing
- -> Abortion InternalServerError []
+ -> Abortion InternalServerError emptyHeaders
$ Just $ show exc
- _ -> Abortion InternalServerError [] $ Just $ show exc
+ _ -> Abortion InternalServerError emptyHeaders $ Just $ show exc
conf = itrConfig itr
-- まだ DecidingHeader 以前の状態だったら、この途中終了
-- を應答に反映させる餘地がある。さうでなければ stderr
if state <= DecidingHeader then
flip runRes itr
$ do setStatus $ aboStatus abo
- -- FIXME: 同じ名前で複數の値があった時は、こ
- -- れではまずいと思ふ。
- mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
+ mapM_ (\ (name, value) -> setHeader name value) $ fromHeaders $ aboHeaders abo
output $ abortPage conf reqM res abo
else
when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
import Data.Sequence (ViewR(..))
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Format
+import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Postprocess
do let cont = Response {
resVersion = HttpVersion 1 1
, resStatus = Continue
- , resHeaders = []
+ , resHeaders = emptyHeaders
}
cont' <- completeUnconditionalHeaders cnf cont
hPutResponse h cont'
( splitBy
, joinWith
, trim
- , noCaseEq
- , noCaseEq'
, isWhiteSpace
, quoteStr
, parseWWWFormURLEncoded
trimHead = dropWhile p
trimTail = reverse . trimHead . reverse
--- |@'noCaseEq' a b@ is equivalent to @('Prelude.map'
--- 'Data.Char.toLower' a) == ('Prelude.map' 'Data.Char.toLower'
--- b)@. See 'noCaseEq''.
-noCaseEq :: String -> String -> Bool
-noCaseEq a b
- = (map toLower a) == (map toLower b)
-{-# INLINE noCaseEq #-}
-
--- |@'noCaseEq'' a b@ is a variant of 'noCaseEq' which first checks
--- the length of two strings to avoid possibly unnecessary comparison.
-noCaseEq' :: String -> String -> Bool
-noCaseEq' a b
- | length a /= length b = False
- | otherwise = noCaseEq a b
-{-# INLINE noCaseEq' #-}
-
-- |@'isWhiteSpace' c@ is 'Prelude.True' iff c is one of SP, HT, CR
-- and LF.
isWhiteSpace :: Char -> Bool
projects / Lucu.git / commitdiff