From 0dc3d31312a12f2b085242841b29eb0d96e9c4ac Mon Sep 17 00:00:00 2001 From: pho Date: Thu, 4 Oct 2007 01:17:37 +0900 Subject: [PATCH] Doc fix, optimization, and more. darcs-hash:20071003161737-62b54-4bf7a3e6c3df2756007e22d5c4978be9ae7faa17.gz --- ImplantFile.hs | 32 +++--- Network/HTTP/Lucu/Abortion.hs | 3 - Network/HTTP/Lucu/DefaultPage.hs | 18 ++-- Network/HTTP/Lucu/Parser.hs | 4 +- Network/HTTP/Lucu/Parser/Http.hs | 7 +- Network/HTTP/Lucu/RFC1123DateTime.hs | 7 +- Network/HTTP/Lucu/Resource.hs | 152 ++++++++++++++++----------- Network/HTTP/Lucu/Resource.hs-boot | 8 -- Network/HTTP/Lucu/Resource/Tree.hs | 22 ++-- Network/HTTP/Lucu/Response.hs | 110 +++++++++---------- Network/HTTP/Lucu/StaticFile.hs | 2 +- Network/HTTP/Lucu/Utils.hs | 6 +- 12 files changed, 196 insertions(+), 175 deletions(-) delete mode 100644 Network/HTTP/Lucu/Resource.hs-boot diff --git a/ImplantFile.hs b/ImplantFile.hs index 29c1145..a16c76e 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -2,7 +2,7 @@ import Codec.Binary.Base64 import Codec.Compression.GZip import Control.Monad import Data.Bits -import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Base (LazyByteString) import qualified Data.ByteString.Lazy as L import Data.Char import Data.Digest.SHA1 @@ -117,8 +117,8 @@ generateHaskellSource opts srcFile exports = [HsEVar (UnQual (HsIdent symName))] imports = [ HsImportDecl undefined (Module "Codec.Binary.Base64") False Nothing Nothing - , HsImportDecl undefined (Module "Data.ByteString.Lazy") - False Nothing (Just (False, [HsIVar (HsIdent "ByteString")])) + , HsImportDecl undefined (Module "Data.ByteString.Base") + False Nothing (Just (False, [HsIVar (HsIdent "LazyByteString")])) , HsImportDecl undefined (Module "Data.ByteString.Lazy") True (Just (Module "L")) Nothing , HsImportDecl undefined (Module "Network.HTTP.Lucu") @@ -207,7 +207,7 @@ generateHaskellSource opts srcFile expOutputGunzipped expOutputGZipped) expOutputGunzipped - = (HsApp (HsVar (UnQual (HsIdent "outputBS"))) + = (HsApp (HsVar (UnQual (HsIdent "outputLBS"))) (HsParen (HsApp (HsVar (UnQual (HsIdent "decompress"))) (HsVar (UnQual (HsIdent "gzippedData")))))) @@ -219,7 +219,7 @@ generateHaskellSource opts srcFile = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding"))) (HsList [HsLit (HsString "gzip")])) doOutputGZipped - = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputBS"))) + = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS"))) (HsVar (UnQual (HsIdent "gzippedData")))) in HsApp (HsCon (UnQual (HsIdent "Just"))) @@ -239,7 +239,7 @@ generateHaskellSource opts srcFile = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType"))) (HsVar (UnQual (HsIdent "contentType")))) doOutputRawData - = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputBS"))) + = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS"))) (HsVar (UnQual (HsIdent "rawData")))) in HsApp (HsCon (UnQual (HsIdent "Just"))) @@ -295,7 +295,7 @@ generateHaskellSource opts srcFile declGZippedData = [ HsTypeSig undefined [HsIdent "gzippedData"] (HsQualType [] - (HsTyCon (UnQual (HsIdent "ByteString")))) + (HsTyCon (UnQual (HsIdent "LazyByteString")))) , HsFunBind [HsMatch undefined (HsIdent "gzippedData") [] (HsUnGuardedRhs defGZippedData) []] ] @@ -311,7 +311,7 @@ generateHaskellSource opts srcFile declRawData = [ HsTypeSig undefined [HsIdent "rawData"] (HsQualType [] - (HsTyCon (UnQual (HsIdent "ByteString")))) + (HsTyCon (UnQual (HsIdent "LazyByteString")))) , HsFunBind [HsMatch undefined (HsIdent "rawData") [] (HsUnGuardedRhs defRawData) []] ] @@ -397,7 +397,7 @@ getLastModified "-" = getClockTime getLastModified fpath = getModificationTime fpath -getETag :: [CmdOpt] -> ByteString -> IO String +getETag :: [CmdOpt] -> LazyByteString -> IO String getETag opts input = let eTagOpts = filter (\ x -> case x of OptETag _ -> True @@ -425,7 +425,7 @@ getETag opts input | n < 16 = (chr $ ord 'a' + n - 10) -openInput :: FilePath -> IO ByteString +openInput :: FilePath -> IO LazyByteString openInput "-" = L.getContents openInput fpath = L.readFile fpath @@ -458,7 +458,7 @@ openOutput opts -} module Foo.Bar.Baz (baz) where import Codec.Binary.Base64 - import Data.ByteString.Lazy (ByteString) + import Data.ByteString.Base (LazyByteString) import qualified Data.ByteString.Lazy as L import Network.HTTP.Lucu import System.Time @@ -470,7 +470,7 @@ openOutput opts , resGet = Just (do foundEntity entityTag lastModified setContentType contentType - outputBS rawData) + outputLBS rawData) , resHead = Nothing , resPost = Nothing , resPut = Nothing @@ -486,7 +486,7 @@ openOutput opts contentType :: MIMEType contentType = read "image/png" - rawData :: ByteString + rawData :: LazyByteString rawData = L.pack (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ...") ------------------------------------------------------------------------------ @@ -507,10 +507,10 @@ openOutput opts mustGunzip <- liftM not (isEncodingAcceptable "gzip") if mustGunzip then - outputBS (decompress gzippedData) + outputLBS (decompress gzippedData) else do setContentEncoding ["gzip"] - outputBS gzippedData + outputLBS gzippedData , resHead = Nothing , resPost = Nothing , resPut = Nothing @@ -518,7 +518,7 @@ openOutput opts } -- rawData の代はりに gzippedData - gzippedData :: ByteString + gzippedData :: LazyByteString gzippedData = L.pack (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...") ------------------------------------------------------------------------------ -} diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index ef70477..9ff629d 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -23,7 +23,6 @@ import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response -import {-# SOURCE #-} Network.HTTP.Lucu.Resource import System.IO.Unsafe import Text.XML.HXT.Arrow.WriteDocument import Text.XML.HXT.Arrow.XmlArrow @@ -68,7 +67,6 @@ abort status headers msg exc = DynException (toDyn abo) in liftIO $ throwIO exc -{-# SPECIALIZE abort :: StatusCode -> [ (String, String) ] -> Maybe String -> Resource a #-} -- |Computation of @'abortSTM' status headers msg@ just computes -- 'abort' in a 'Control.Monad.STM.STM' monad. @@ -82,7 +80,6 @@ abortSTM status headers msg abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c abortA = arrIO3 abort -{-# SPECIALIZE abortA :: IOSArrow (StatusCode, ([ (String, String) ], Maybe String)) c #-} -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 05acb60..b4413ce 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -60,15 +60,15 @@ writeDefaultPage itr mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree mkDefaultPage conf status msgA = conf `seq` status `seq` msgA `seq` - let (sCode, sMsg) = statusCode status - sig = cnfServerSoftware conf - ++ " at " - ++ cnfServerHost conf - ++ ( case cnfServerPort conf of - Service serv -> ", service " ++ serv - PortNumber num -> ", port " ++ show num - UnixSocket path -> ", unix socket " ++ show path - ) + let (# sCode, sMsg #) = statusCode status + sig = cnfServerSoftware conf + ++ " at " + ++ cnfServerHost conf + ++ ( case cnfServerPort conf of + Service serv -> ", service " ++ serv + PortNumber num -> ", port " ++ show num + UnixSocket path -> ", unix socket " ++ show path + ) in ( eelem "/" += ( eelem "html" += sattr "xmlns" "http://www.w3.org/1999/xhtml" diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 5671ec0..c40cacd 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -93,8 +93,8 @@ instance Monad Parser where failP :: Parser a failP = fail undefined --- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(result, --- remaining)@. +-- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(# result, +-- remaining #)@. parse :: Parser a -> LazyByteString -> (# ParserResult a, LazyByteString #) parse p input -- input は lazy である必要有り。 = p `seq` diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs index 77dbe7f..a5dfbd9 100644 --- a/Network/HTTP/Lucu/Parser/Http.hs +++ b/Network/HTTP/Lucu/Parser/Http.hs @@ -20,14 +20,15 @@ module Network.HTTP.Lucu.Parser.Http import Data.List import Network.HTTP.Lucu.Parser --- |@'isCtl' c@ is False iff @0x20 <= @c@ < 0x7F@. +-- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= @c@ < 0x7F@. isCtl :: Char -> Bool isCtl c | c < '\x1f' = True | c >= '\x7f' = True | otherwise = False --- |@'isSeparator' c@ is True iff c is one of HTTP separators. +-- |@'isSeparator' c@ is 'Prelude.True' iff c is one of HTTP +-- separators. isSeparator :: Char -> Bool isSeparator '(' = True isSeparator ')' = True @@ -50,7 +51,7 @@ isSeparator ' ' = True isSeparator '\t' = True isSeparator _ = False --- |@'isChar' c@ is True iff @c <= 0x7f@. +-- |@'isChar' c@ is 'Prelude.True' iff @c <= 0x7f@. isChar :: Char -> Bool isChar c | c <= '\x7f' = True diff --git a/Network/HTTP/Lucu/RFC1123DateTime.hs b/Network/HTTP/Lucu/RFC1123DateTime.hs index 2cd06cc..e9300a5 100644 --- a/Network/HTTP/Lucu/RFC1123DateTime.hs +++ b/Network/HTTP/Lucu/RFC1123DateTime.hs @@ -19,7 +19,8 @@ month = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", week :: [String] week = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"] --- |Format a @CalendarTime@ to RFC 1123 Date and Time string. +-- |Format a 'System.Time.CalendarTime' to RFC 1123 Date and Time +-- string. formatRFC1123DateTime :: CalendarTime -> String formatRFC1123DateTime time = time `seq` @@ -41,8 +42,8 @@ formatRFC1123DateTime time id (ctTZName time) --- |Format a @ClockTime@ to HTTP Date and Time. Time zone will be --- always UTC but prints as GMT. +-- |Format a 'System.Time.ClockTime' to HTTP Date and Time. Time zone +-- will be always UTC but prints as GMT. formatHTTPDateTime :: ClockTime -> String formatHTTPDateTime time = time `seq` diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 8942c76..8e25904 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,8 +1,9 @@ -- #prune -- |This is the Resource Monad; monadic actions to define the behavior --- of each resources. The 'Resource' Monad is a kind of IO Monad thus --- it implements MonadIO class. It is also a state machine. +-- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO' +-- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is +-- also a state machine. -- -- Request Processing Flow: -- @@ -61,6 +62,7 @@ module Network.HTTP.Lucu.Resource ( -- * Monad Resource + , runRes -- private -- * Actions @@ -100,8 +102,8 @@ module Network.HTTP.Lucu.Resource -- Body/. , input , inputChunk - , inputBS - , inputChunkBS + , inputLBS + , inputChunkLBS , inputForm , defaultLimit @@ -122,8 +124,8 @@ module Network.HTTP.Lucu.Resource -- Body/. , output , outputChunk - , outputBS - , outputChunkBS + , outputLBS + , outputChunkLBS , driftTo ) @@ -132,8 +134,8 @@ module Network.HTTP.Lucu.Resource 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.Lazy.Char8 (ByteString) import Data.List import Data.Maybe import Network.HTTP.Lucu.Abortion @@ -155,27 +157,50 @@ import Network.Socket import Network.URI import System.Time --- |The 'Resource' monad. /Interaction/ is an internal state thus it --- is not exposed to users. This monad implements 'MonadIO' so it can --- do any IO actions. -type Resource a = ReaderT Interaction IO a +-- |The 'Resource' monad. This monad implements +-- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO' +-- actions. +newtype Resource a = Resource { unRes :: ReaderT Interaction IO a } + +instance Functor Resource where + fmap f c = Resource (fmap f (unRes c)) + +instance Monad Resource where + c >>= f = Resource (unRes c >>= unRes . f) + return = Resource . return + fail = Resource . fail + +instance MonadIO Resource where + liftIO = Resource . liftIO + + +runRes :: Resource a -> Interaction -> IO a +runRes r itr + = runReaderT (unRes r) itr + + +getInteraction :: Resource Interaction +getInteraction = Resource ask + -- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for -- the httpd. getConfig :: Resource Config -getConfig = do itr <- ask +getConfig = do itr <- getInteraction return $! itrConfig itr --- |Get the SockAddr of the remote host. If you want a string --- representation instead of SockAddr, use 'getRemoteAddr''. +-- |Get the 'Network.Socket.SockAddr' of the remote host. If you want +-- a string representation instead of 'Network.Socket.SockAddr', use +-- 'getRemoteAddr''. getRemoteAddr :: Resource SockAddr -getRemoteAddr = do itr <- ask +getRemoteAddr = do itr <- getInteraction return $! itrRemoteAddr itr -- |Get the string representation of the address of remote host. If --- you want a SockAddr instead of String, use 'getRemoteAddr'. +-- you want a 'Network.Socket.SockAddr' instead of String, use +-- 'getRemoteAddr'. getRemoteAddr' :: Resource String getRemoteAddr' = do addr <- getRemoteAddr case addr of @@ -194,7 +219,7 @@ getRemoteAddr' = do addr <- getRemoteAddr -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents -- the request header. In general you don't have to use this action. getRequest :: Resource Request -getRequest = do itr <- ask +getRequest = do itr <- getInteraction req <- liftIO $! atomically $! readItr itr itrRequest fromJust return req @@ -236,7 +261,7 @@ getRequestVersion = do req <- getRequest -- > , ... -- > } getResourcePath :: Resource [String] -getResourcePath = do itr <- ask +getResourcePath = do itr <- getInteraction return $! fromJust $! itrResourcePath itr @@ -368,7 +393,7 @@ foundEntity tag timeStamp -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into -- the response. -- --- This action is not preferred. You should use 'foundEntity' when +-- This action is not preferred. You should use 'foundEntity' whenever -- possible. foundETag :: ETag -> Resource () foundETag tag @@ -424,7 +449,7 @@ foundETag tag -- modification time are unsafe because it is possible to mess up such -- tests by modifying the entity twice in a second. -- --- This action is not preferred. You should use 'foundEntity' when +-- This action is not preferred. You should use 'foundEntity' whenever -- possible. foundTimeStamp :: ClockTime -> Resource () foundTimeStamp timeStamp @@ -509,23 +534,25 @@ foundNoEntity msgM -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See -- 'defaultLimit'. -- --- Note that 'inputBS' is more efficient than 'input' so you should +-- Note that 'inputLBS' is more efficient than 'input' so you should -- use it whenever possible. input :: Int -> Resource String input limit = limit `seq` - inputBS limit >>= return . B.unpack + inputLBS limit >>= return . B.unpack -- | This is mostly the same as 'input' but is more --- efficient. 'inputBS' returns a lazy ByteString but it's not really --- lazy: reading from the socket just happens at the computation of --- 'inputBS', not at the lazy evaluation of the ByteString. The same --- goes for 'inputChunkBS'. -inputBS :: Int -> Resource ByteString -inputBS limit +-- efficient. 'inputLBS' returns a +-- 'Data.ByteString.Base.LazyByteString' but it's not really lazy: +-- reading from the socket just happens at the computation of +-- 'inputLBS', not at the evaluation of the +-- 'Data.ByteString.Base.LazyByteString'. The same goes for +-- 'inputChunkLBS'. +inputLBS :: Int -> Resource LazyByteString +inputLBS limit = limit `seq` do driftTo GettingBody - itr <- ask + itr <- getInteraction hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id chunk <- if hasBody then askForInput itr @@ -534,7 +561,7 @@ inputBS limit return B.empty return chunk where - askForInput :: Interaction -> Resource ByteString + askForInput :: Interaction -> Resource LazyByteString askForInput itr = itr `seq` do let defaultLimit = cnfMaxEntityLength $ itrConfig itr @@ -543,7 +570,7 @@ inputBS limit else limit when (actualLimit <= 0) - $ fail ("inputBS: limit must be positive: " ++ show actualLimit) + $ fail ("inputLBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト liftIO $! atomically $! do chunkLen <- readItr itr itrReqChunkLength id @@ -592,20 +619,20 @@ inputBS limit -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See -- 'defaultLimit'. -- --- Note that 'inputChunkBS' is more efficient than 'inputChunk' so you +-- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you -- should use it whenever possible. inputChunk :: Int -> Resource String inputChunk limit = limit `seq` - inputChunkBS limit >>= return . B.unpack + inputChunkLBS limit >>= return . B.unpack -- | This is mostly the same as 'inputChunk' but is more --- efficient. See 'inputBS'. -inputChunkBS :: Int -> Resource ByteString -inputChunkBS limit +-- efficient. See 'inputLBS'. +inputChunkLBS :: Int -> Resource LazyByteString +inputChunkLBS limit = limit `seq` do driftTo GettingBody - itr <- ask + itr <- getInteraction hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id chunk <- if hasBody then askForInput itr @@ -614,7 +641,7 @@ inputChunkBS limit return B.empty return chunk where - askForInput :: Interaction -> Resource ByteString + askForInput :: Interaction -> Resource LazyByteString askForInput itr = itr `seq` do let defaultLimit = cnfMaxEntityLength $! itrConfig itr @@ -623,7 +650,7 @@ inputChunkBS limit else limit when (actualLimit <= 0) - $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit) + $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト liftIO $! atomically $! do writeItr itr itrReqBodyWanted $! Just actualLimit @@ -677,7 +704,7 @@ inputForm limit = abort UnsupportedMediaType [] (Just $! "Sorry, inputForm does not currently support multipart/form-data.") --- | This is just a constant -1. It's better to say @'input' +-- | This is just a constant @-1@. It's better to say @'input' -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly -- the same. defaultLimit :: Int @@ -693,7 +720,7 @@ setStatus :: StatusCode -> Resource () setStatus code = code `seq` do driftTo DecidingHeader - itr <- ask + itr <- getInteraction liftIO $! atomically $! updateItr itr itrResponse $! \ res -> res { resStatus = code @@ -722,13 +749,13 @@ setHeader name value setHeader' :: String -> String -> Resource () setHeader' name value = name `seq` value `seq` - do itr <- ask + do itr <- getInteraction liftIO $ atomically $ updateItr itr itrResponse $ H.setHeader name value -- | Computation of @'redirect' code uri@ sets the response status to --- @code@ and \"Location\" header to @uri@. @code@ must satisfy +-- @code@ and \"Location\" header to @uri@. The @code@ must satisfy -- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error. redirect :: StatusCode -> URI -> Resource () redirect code uri @@ -771,35 +798,35 @@ setContentEncoding codings -- apply 'output' to an infinite string, such as a lazy stream of -- \/dev\/random. -- --- Note that 'outputBS' is more efficient than 'output' so you should +-- Note that 'outputLBS' is more efficient than 'output' so you should -- use it whenever possible. output :: String -> Resource () -output str = outputBS $! B.pack str +output str = outputLBS $! B.pack str {-# INLINE output #-} -- | This is mostly the same as 'output' but is more efficient. -outputBS :: ByteString -> Resource () -outputBS str = do outputChunkBS str - driftTo Done -{-# INLINE outputBS #-} +outputLBS :: LazyByteString -> Resource () +outputLBS str = do outputChunkLBS str + driftTo Done +{-# INLINE outputLBS #-} -- | Computation of @'outputChunk' str@ writes @str@ as a part of -- response body. You can compute this action multiple times to write -- a body little at a time. It is safe to apply 'outputChunk' to an -- infinite string. -- --- Note that 'outputChunkBS' is more efficient than 'outputChunk' so +-- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so -- you should use it whenever possible. outputChunk :: String -> Resource () -outputChunk str = outputChunkBS $! B.pack str +outputChunk str = outputChunkLBS $! B.pack str {-# INLINE outputChunk #-} -- | This is mostly the same as 'outputChunk' but is more efficient. -outputChunkBS :: ByteString -> Resource () -outputChunkBS str +outputChunkLBS :: LazyByteString -> Resource () +outputChunkLBS str = str `seq` do driftTo DecidingBody - itr <- ask + itr <- getInteraction let limit = cnfMaxOutputChunkLength $ itrConfig itr when (limit <= 0) @@ -816,17 +843,16 @@ outputChunkBS str $ liftIO $ atomically $ writeItr itr itrBodyIsNull False where - {- チャンクの大きさは Config で制限されてゐる。もし例へば - /dev/zero を B.readFile して作った ByteString をそのまま - ResponseWriter に渡したりすると大變な事が起こる。何故なら - ResponseWriter はTransfer-Encoding: chunked の時、ヘッダを書く - 爲にチャンクの大きさを測るから、その時に起こるであらう事は言ふ - までも無い。 -} - sendChunks :: ByteString -> Int -> Resource () + -- チャンクの大きさは Config で制限されてゐる。もし例へば + -- "/dev/zero" を B.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 <- ask + itr <- getInteraction liftIO $ atomically $ do buf <- readItr itr itrBodyToSend id if B.null buf then @@ -860,7 +886,7 @@ outputChunkBS str driftTo :: InteractionState -> Resource () driftTo newState = newState `seq` - do itr <- ask + do itr <- getInteraction liftIO $ atomically $ do oldState <- readItr itr itrState id if newState < oldState then throwStateError oldState newState diff --git a/Network/HTTP/Lucu/Resource.hs-boot b/Network/HTTP/Lucu/Resource.hs-boot deleted file mode 100644 index 77fdfb9..0000000 --- a/Network/HTTP/Lucu/Resource.hs-boot +++ /dev/null @@ -1,8 +0,0 @@ -{- -*- haskell -*- -} -module Network.HTTP.Lucu.Resource - where - -import Control.Monad.Reader -import Network.HTTP.Lucu.Interaction - -type Resource a = ReaderT Interaction IO a \ No newline at end of file diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index c2f6add..149fa9d 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -14,7 +14,7 @@ module Network.HTTP.Lucu.Resource.Tree import Control.Concurrent import Control.Concurrent.STM import Control.Exception -import Control.Monad.Reader +import Control.Monad import Data.Dynamic import Data.List import qualified Data.Map as M @@ -41,9 +41,11 @@ import Prelude hiding (catch) -- | 'ResourceDef' is basically a set of -- 'Network.HTTP.Lucu.Resource.Resource' monads for each HTTP methods. data ResourceDef = ResourceDef { - -- | Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a - -- native thread (spawned using @forkOS@) or to run it on a user - -- thread (spanwed using @forkIO@). Generally you don't + -- |Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a + -- native thread (spawned by 'Control.Concurrent.forkOS') or to + -- run it on a user thread (spanwed by + -- 'Control.Concurrent.forkIO'). Generally you don't need to set + -- this field to 'Prelude.True'. resUsesNativeThread :: !Bool -- | Whether to be greedy or not. -- @@ -168,10 +170,10 @@ runResource :: ResourceDef -> Interaction -> IO ThreadId runResource def itr = def `seq` itr `seq` fork - $! catch ( runReaderT ( do req <- getRequest - fromMaybe notAllowed $ rsrc req - driftTo Done - ) itr + $! catch ( runRes ( do req <- getRequest + fromMaybe notAllowed $ rsrc req + driftTo Done + ) itr ) $ \ exc -> processException exc where @@ -227,7 +229,7 @@ runResource def itr reqM <- atomically $ readItr itr itrRequest id res <- atomically $ readItr itr itrResponse id if state <= DecidingHeader then - flip runReaderT itr + flip runRes itr $ do setStatus $ aboStatus abo -- FIXME: 同じ名前で複數の値があった時は、こ -- れではまずいと思ふ。 @@ -237,7 +239,7 @@ runResource def itr when (cnfDumpTooLateAbortionToStderr $ itrConfig itr) $ hPutStrLn stderr $ show abo - flip runReaderT itr $ driftTo Done + flip runRes itr $ driftTo Done formatIOE :: IOError -> String formatIOE ioE = if isUserError ioE then diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index 913c491..9239cba 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -78,7 +78,7 @@ data StatusCode = Continue deriving (Typeable, Eq) instance Show StatusCode where - show sc = let (num, msg) = statusCode sc + show sc = let (# num, msg #) = statusCode sc in (fmtDec 3 num) ++ " " ++ msg @@ -109,87 +109,87 @@ hPutStatus h sc = h `seq` sc `seq` hPutStr h (show sc) --- |@'isInformational' sc@ is True iff @sc < 200@. +-- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@. isInformational :: StatusCode -> Bool isInformational = doesMeet (< 200) --- |@'isSuccessful' sc@ is True iff @200 <= sc < 300@. +-- |@'isSuccessful' sc@ is 'Prelude.True' iff @200 <= sc < 300@. isSuccessful :: StatusCode -> Bool isSuccessful = doesMeet (\ n -> n >= 200 && n < 300) --- |@'isRedirection' sc@ is True iff @300 <= sc < 400@. +-- |@'isRedirection' sc@ is 'Prelude.True' iff @300 <= sc < 400@. isRedirection :: StatusCode -> Bool isRedirection = doesMeet (\ n -> n >= 300 && n < 400) --- |@'isError' sc@ is True iff @400 <= sc@ +-- |@'isError' sc@ is 'Prelude.True' iff @400 <= sc@ isError :: StatusCode -> Bool isError = doesMeet (>= 400) --- |@'isClientError' sc@ is True iff @400 <= sc < 500@. +-- |@'isClientError' sc@ is 'Prelude.True' iff @400 <= sc < 500@. isClientError :: StatusCode -> Bool isClientError = doesMeet (\ n -> n >= 400 && n < 500) --- |@'isServerError' sc@ is True iff @500 <= sc@. +-- |@'isServerError' sc@ is 'Prelude.True' iff @500 <= sc@. isServerError :: StatusCode -> Bool isServerError = doesMeet (>= 500) doesMeet :: (Int -> Bool) -> StatusCode -> Bool -doesMeet p sc = let (num, _) = statusCode sc +doesMeet p sc = let (# num, _ #) = statusCode sc in p num -- |@'statusCode' sc@ returns a tuple of numeric and textual -- representation of @sc@. -statusCode :: StatusCode -> (Int, String) -statusCode Continue = (100, "Continue") -statusCode SwitchingProtocols = (101, "Switching Protocols") -statusCode Processing = (102, "Processing") +statusCode :: StatusCode -> (# Int, String #) +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 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 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 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") \ No newline at end of file +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" #) \ No newline at end of file diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 3b8222f..12cf78b 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -73,7 +73,7 @@ handleStaticFile path Just mime -> setContentType mime -- 實際にファイルを讀んで送る - (liftIO $ B.readFile path) >>= outputBS + (liftIO $ B.readFile path) >>= outputLBS else do isDir <- liftIO $ doesDirectoryExist path if isDir then diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index d92516e..0c29836 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -40,7 +40,8 @@ trim p = p `seq` trimTail . trimHead trimHead = dropWhile p trimTail = reverse . trimHead . reverse --- |@'noCaseEq' a b@ is equivalent to @(map toLower a) == (map toLower +-- |@'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 @@ -55,7 +56,8 @@ noCaseEq' a b | otherwise = noCaseEq a b {-# INLINE noCaseEq' #-} --- |@'isWhiteSpace' c@ is True iff c is one of SP, HT, CR and LF. +-- |@'isWhiteSpace' c@ is 'Prelude.True' iff c is one of SP, HT, CR +-- and LF. isWhiteSpace :: Char -> Bool isWhiteSpace ' ' = True isWhiteSpace '\t' = True -- 2.40.0