From db4b61223e0d8b34079d3b190fb3e3644b0b4866 Mon Sep 17 00:00:00 2001 From: PHO Date: Tue, 4 Oct 2011 03:13:33 +0900 Subject: [PATCH] Many changes... Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- Lucu.cabal | 5 +- Network/HTTP/Lucu/ContentCoding.hs | 11 +- Network/HTTP/Lucu/DefaultPage.hs | 4 +- Network/HTTP/Lucu/Format.hs | 4 +- Network/HTTP/Lucu/HandleLike.hs | 36 +- Network/HTTP/Lucu/Interaction.hs | 43 +- Network/HTTP/Lucu/MultipartForm.hs | 2 +- Network/HTTP/Lucu/Postprocess.hs | 34 +- Network/HTTP/Lucu/Resource.hs | 917 ++++++++++++++--------------- Network/HTTP/Lucu/Response.hs | 6 +- Network/HTTP/Lucu/Utils.hs | 27 +- 11 files changed, 537 insertions(+), 552 deletions(-) diff --git a/Lucu.cabal b/Lucu.cabal index 0200e77..2521c48 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -48,10 +48,11 @@ Library HsOpenSSL == 0.10.*, ascii == 0.0.*, attoparsec == 0.9.*, - base == 4.3.*, + base == 4.*, base-unicode-symbols == 0.2.*, base64-bytestring == 0.1.*, blaze-builder == 0.3.*, + blaze-textual == 0.2.*, bytestring == 0.9.*, containers == 0.4.*, containers-unicode-symbols == 0.3.*, @@ -65,7 +66,7 @@ Library text == 0.11.*, text-icu == 0.6.*, time == 1.2.*, - time-http == 0.1.*, + time-http == 0.2.*, unix == 2.4.*, zlib == 0.5.* diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs index 7a0918a..315d237 100644 --- a/Network/HTTP/Lucu/ContentCoding.hs +++ b/Network/HTTP/Lucu/ContentCoding.hs @@ -19,7 +19,10 @@ import Network.HTTP.Lucu.Parser.Http import Prelude.Unicode data AcceptEncoding - = AcceptEncoding !CIAscii !(Maybe Double) + = AcceptEncoding { + aeEncoding ∷ !CIAscii + , aeQValue ∷ !(Maybe Double) + } deriving (Eq, Show) instance Ord AcceptEncoding where @@ -31,16 +34,16 @@ instance Ord AcceptEncoding where q1' = fromMaybe 0 q1 q2' = fromMaybe 0 q2 -acceptEncodingListP ∷ Parser [(CIAscii, Maybe Double)] +acceptEncodingListP ∷ Parser [AcceptEncoding] acceptEncodingListP = listOf accEncP -accEncP ∷ Parser (CIAscii, Maybe Double) +accEncP ∷ Parser AcceptEncoding accEncP = do coding ← toCIAscii <$> token qVal ← option Nothing $ do _ ← string ";q=" q ← qvalue return $ Just q - return (normalizeCoding coding, qVal) + return $ AcceptEncoding (normalizeCoding coding) qVal normalizeCoding ∷ CIAscii → CIAscii normalizeCoding coding diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index dbc3835..5b62418 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -48,9 +48,9 @@ getDefaultPage !conf !req !res writeDefaultPage ∷ Interaction → STM () writeDefaultPage !itr -- Content-Type が正しくなければ補完できない。 - = do res ← readItr itr itrResponse id + = do res ← readItr itrResponse id itr when (getHeader "Content-Type" res == Just defaultPageContentType) - $ do reqM ← readItr itr itrRequest id + $ do reqM ← readItr itrRequest id itr let conf = itrConfig itr page = getDefaultPage conf reqM res diff --git a/Network/HTTP/Lucu/Format.hs b/Network/HTTP/Lucu/Format.hs index 42508b9..8db643d 100644 --- a/Network/HTTP/Lucu/Format.hs +++ b/Network/HTTP/Lucu/Format.hs @@ -7,10 +7,10 @@ -- 本當にこんなものを自分で書く必要があったのだらうか。Printf は重いの -- で駄目だが、それ以外のモジュールを探しても見付からなかった。 module Network.HTTP.Lucu.Format - ( fmtInt + ( {-fmtInt , fmtDec - , fmtHex + , fmtHex-} ) where import qualified Blaze.ByteString.Builder.Char8 as BC diff --git a/Network/HTTP/Lucu/HandleLike.hs b/Network/HTTP/Lucu/HandleLike.hs index aa4dacb..f58264d 100644 --- a/Network/HTTP/Lucu/HandleLike.hs +++ b/Network/HTTP/Lucu/HandleLike.hs @@ -1,32 +1,28 @@ +{-# LANGUAGE + UnicodeSyntax + #-} module Network.HTTP.Lucu.HandleLike ( HandleLike(..) ) where - import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Char8 as L import qualified OpenSSL.Session as SSL -import OpenSSL.X509 +import OpenSSL.X509 import qualified System.IO as I - class HandleLike h where - hGetLBS :: h -> IO L.ByteString - hPutLBS :: h -> L.ByteString -> IO () - - hGetBS :: h -> Int -> IO B.ByteString - hPutBS :: h -> B.ByteString -> IO () - - hPutChar :: h -> Char -> IO () + hGetLBS ∷ h → IO L.ByteString + hPutLBS ∷ h → L.ByteString → IO () - hPutStr :: h -> String -> IO () - hPutStrLn :: h -> String -> IO () + hGetBS ∷ h → Int → IO B.ByteString + hPutBS ∷ h → B.ByteString → IO () - hGetPeerCert :: h -> IO (Maybe X509) + hGetPeerCert ∷ h → IO (Maybe X509) hGetPeerCert = const $ return Nothing - hFlush :: h -> IO () - hClose :: h -> IO () + hFlush ∷ h → IO () + hClose ∷ h → IO () instance HandleLike I.Handle where @@ -36,11 +32,6 @@ instance HandleLike I.Handle where hGetBS = B.hGet hPutBS = B.hPut - hPutChar = I.hPutChar - - hPutStr = I.hPutStr - hPutStrLn = I.hPutStrLn - hFlush = I.hFlush hClose = I.hClose @@ -52,11 +43,6 @@ instance HandleLike SSL.SSL where hGetBS = SSL.read hPutBS = SSL.write - hPutChar s = hPutLBS s . L.singleton - - hPutStr s = hPutLBS s . L.pack - hPutStrLn s = hPutLBS s . L.pack . (++ "\n") - hGetPeerCert s = do isValid <- SSL.getVerifyResult s if isValid then diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 19faec2..52a5e2e 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -11,17 +11,20 @@ module Network.HTTP.Lucu.Interaction , newInteraction , defaultPageContentType + , chunksToLBS + , chunksFromLBS + , writeItr , readItr - , readItrF , updateItr - , updateItrF ) where import Control.Applicative import Control.Concurrent.STM import Data.Ascii (Ascii) import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Foldable import Data.Sequence (Seq) import qualified Data.Sequence as S import Network.Socket @@ -151,28 +154,26 @@ newInteraction !conf !port !addr !cert !req , itrWroteHeader = wroteHeader } -writeItr ∷ Interaction → (Interaction → TVar a) → a → STM () +chunksToLBS ∷ Seq BS.ByteString → LBS.ByteString +{-# INLINE chunksToLBS #-} +chunksToLBS = LBS.fromChunks ∘ toList + +chunksFromLBS ∷ LBS.ByteString → Seq BS.ByteString +{-# INLINE chunksFromLBS #-} +chunksFromLBS = S.fromList ∘ LBS.toChunks + +writeItr ∷ (Interaction → TVar a) → a → Interaction → STM () {-# INLINE writeItr #-} -writeItr itr accessor - = writeTVar (accessor itr) +writeItr accessor a itr + = writeTVar (accessor itr) a -readItr ∷ Interaction → (Interaction → TVar a) → (a → b) → STM b +readItr ∷ (Interaction → TVar a) → (a → b) → Interaction → STM b {-# INLINE readItr #-} -readItr itr accessor reader +readItr accessor reader itr = reader <$> readTVar (accessor itr) -readItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → b) → STM (f b) -{-# INLINE readItrF #-} -readItrF itr accessor reader - = readItr itr accessor (fmap reader) - -updateItr ∷ Interaction → (Interaction → TVar a) → (a → a) → STM () +updateItr ∷ (Interaction → TVar a) → (a → a) → Interaction → STM () {-# INLINE updateItr #-} -updateItr itr accessor updator - = do old ← readItr itr accessor id - writeItr itr accessor (updator old) - -updateItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → a) → STM () -{-# INLINE updateItrF #-} -updateItrF itr accessor - = updateItr itr accessor ∘ fmap +updateItr accessor updator itr + = do old ← readItr accessor id itr + writeItr accessor (updator old) itr diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index 8d09d70..c36b819 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -92,7 +92,7 @@ partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData)) {-# INLINEABLE partToFormPair #-} partToFormPair pt | dType (ptContDispo pt) ≡ "form-data" - = do name ← partName pt + = do name ← partName pt let fname = partFileName pt let fd = FormData { fdFileName = fname diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 49c95e8..a7c2e07 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -15,9 +15,6 @@ 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 Data.Maybe import Data.Monoid.Unicode import Data.Time @@ -31,7 +28,6 @@ import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Prelude.Unicode -import System.IO.Unsafe {- @@ -68,8 +64,8 @@ import System.IO.Unsafe postprocess ∷ Interaction → STM () postprocess !itr - = do reqM ← readItr itr itrRequest id - res ← readItr itr itrResponse id + = do reqM ← readItr itrRequest id itr + res ← readItr itrResponse id itr let sc = resStatus res unless (any (\ p → p sc) [isSuccessful, isRedirection, isError]) @@ -85,26 +81,26 @@ postprocess !itr ⊕ printStatusCode sc ⊕ " but no Allow header." ) - when (sc /= NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing) + when (sc ≢ NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing) $ abortSTM InternalServerError [] $ Just $ A.toText ( "The status code was " ⊕ printStatusCode sc ⊕ " but no Location header." ) - when (reqM /= Nothing) relyOnRequest + when (reqM ≢ Nothing) relyOnRequest -- itrResponse の内容は relyOnRequest によって變へられてゐる可 -- 能性が高い。 - do oldRes ← readItr itr itrResponse id + do oldRes ← readItr itrResponse id itr newRes ← unsafeIOToSTM $ completeUnconditionalHeaders (itrConfig itr) oldRes - writeItr itr itrResponse newRes + writeItr itrResponse newRes itr where relyOnRequest ∷ STM () relyOnRequest - = do status ← readItr itr itrResponse resStatus - req ← readItr itr itrRequest fromJust + = do status ← readItr itrResponse resStatus itr + req ← readItr itrRequest fromJust itr let reqVer = reqVersion req canHaveBody = if reqMethod req ≡ HEAD then @@ -125,10 +121,10 @@ postprocess !itr if canHaveBody then when (reqVer ≡ HttpVersion 1 1) $ do updateRes $ setHeader "Transfer-Encoding" "chunked" - writeItr itr itrWillChunkBody True + writeItr itrWillChunkBody True itr else -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す - when (reqMethod req /= HEAD) + when (reqMethod req ≢ HEAD) $ do updateRes $ deleteHeader "Content-Type" updateRes $ deleteHeader "Etag" updateRes $ deleteHeader "Last-Modified" @@ -137,9 +133,9 @@ postprocess !itr case conn of Nothing → return () Just value → when (A.toCIAscii value ≡ "close") - $ writeItr itr itrWillClose True + $ writeItr itrWillClose True itr - willClose ← readItr itr itrWillClose id + willClose ← readItr itrWillClose id itr when willClose $ updateRes $ setHeader "Connection" "close" @@ -148,11 +144,11 @@ postprocess !itr readHeader ∷ CIAscii → STM (Maybe Ascii) {-# INLINE readHeader #-} - readHeader = readItr itr itrResponse ∘ getHeader + readHeader k = readItr itrResponse (getHeader k) itr updateRes ∷ (Response → Response) → STM () {-# INLINE updateRes #-} - updateRes = updateItr itr itrResponse + updateRes f = updateItr itrResponse f itr completeUnconditionalHeaders ∷ Config → Response → IO Response completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer @@ -169,4 +165,4 @@ completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer Just _ → return res' getCurrentDate ∷ IO Ascii -getCurrentDate = HTTP.format <$> getCurrentTime +getCurrentDate = HTTP.toAscii <$> getCurrentTime diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 3bc7524..2672399 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,5 +1,9 @@ {-# LANGUAGE - UnboxedTuples + BangPatterns + , GeneralizedNewtypeDeriving + , DoAndIfThenElse + , OverloadedStrings + , RecordWildCards , UnicodeSyntax #-} {-# OPTIONS_HADDOCK prune #-} @@ -110,8 +114,6 @@ module Network.HTTP.Lucu.Resource -- Body/. , input , inputChunk - , inputLBS - , inputChunkLBS , inputForm , defaultLimit @@ -133,96 +135,90 @@ module Network.HTTP.Lucu.Resource -- Body/. , output , outputChunk - , outputLBS - , outputChunkLBS - , driftTo + , driftTo -- private ) where -import Control.Concurrent.STM -import Control.Monad.Reader -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.ByteString.Lazy as Lazy (ByteString) -import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) -import Data.Char -import Data.List -import Data.Maybe -import Data.Time +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad.Reader +import Control.Monad.Unicode +import Data.Ascii (Ascii, CIAscii) +import qualified Data.Ascii as A +import qualified Data.Attoparsec.Char8 as P +import qualified Data.Attoparsec.Lazy as LP +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid.Unicode +import qualified Data.Sequence as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import Data.Time import qualified Data.Time.HTTP as HTTP -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Authorization -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.ContentCoding -import Network.HTTP.Lucu.DefaultPage -import Network.HTTP.Lucu.ETag +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Authorization +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.ContentCoding +import Network.HTTP.Lucu.DefaultPage +import Network.HTTP.Lucu.ETag import qualified Network.HTTP.Lucu.Headers as H -import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.MultipartForm -import Network.HTTP.Lucu.Postprocess -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.MIMEType -import Network.HTTP.Lucu.Utils -import Network.Socket hiding (accept) -import Network.URI hiding (path) -import OpenSSL.X509 - --- |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 +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.MultipartForm +import Network.HTTP.Lucu.Postprocess +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.Utils +import Network.Socket hiding (accept) +import Network.URI hiding (path) +import OpenSSL.X509 +import Prelude.Unicode + +-- |The 'Resource' monad. This monad implements 'MonadIO' so it can do +-- any 'IO' actions. +newtype Resource a + = Resource { + unRes ∷ ReaderT Interaction IO a + } + deriving (Applicative, Functor, Monad, MonadIO) + +runRes ∷ Resource a → Interaction → IO a runRes r itr = runReaderT (unRes r) itr - -getInteraction :: Resource Interaction +getInteraction ∷ Resource Interaction getInteraction = Resource ask +-- |Get the 'Config' value which is used for the httpd. +getConfig ∷ Resource Config +getConfig = itrConfig <$> getInteraction --- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for --- the httpd. -getConfig :: Resource Config -getConfig = do itr <- getInteraction - return $! itrConfig itr - - --- |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 <- getInteraction - return $! itrRemoteAddr itr - +-- |Get the 'SockAddr' of the remote host. If you want a string +-- representation instead of 'SockAddr', use 'getRemoteAddr''. +getRemoteAddr ∷ Resource SockAddr +getRemoteAddr = itrRemoteAddr <$> getInteraction -- |Get the string representation of the address of remote host. If --- you want a 'Network.Socket.SockAddr' instead of 'Prelude.String', --- use 'getRemoteAddr'. -getRemoteAddr' :: Resource String -getRemoteAddr' = do addr <- getRemoteAddr - (Just str, _) <- liftIO $! getNameInfo [NI_NUMERICHOST] True False addr - return str +-- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'. +getRemoteAddr' ∷ Resource HostName +getRemoteAddr' + = do sa ← getRemoteAddr + (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False False sa + return a -- |Resolve an address to the remote host. -getRemoteHost :: Resource String -getRemoteHost = do addr <- getRemoteAddr - (Just str, _) <- liftIO $! getNameInfo [] True False addr - return str +getRemoteHost ∷ Resource (Maybe HostName) +getRemoteHost + = do sa ← getRemoteAddr + fst <$> (liftIO $ getNameInfo [] True False sa) -- | Return the X.509 certificate of the client, or 'Nothing' if: -- @@ -231,34 +227,29 @@ getRemoteHost = do addr <- getRemoteAddr -- * The client didn't send us its certificate. -- -- * The 'OpenSSL.Session.VerificationMode' of --- 'OpenSSL.Session.SSLContext' in --- 'Network.HTTP.Lucu.Config.SSLConfig' has not been set to --- 'OpenSSL.Session.VerifyPeer'. -getRemoteCertificate :: Resource (Maybe X509) -getRemoteCertificate = do itr <- getInteraction - return $! itrRemoteCert itr - --- |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 <- getInteraction - req <- liftIO $! atomically $! readItr itr itrRequest fromJust - return req - --- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request. -getMethod :: Resource Method -getMethod = do req <- getRequest - return $! reqMethod req +-- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to +-- 'OpenSSL.Session.VerifyPeer'. +getRemoteCertificate ∷ Resource (Maybe X509) +getRemoteCertificate = itrRemoteCert <$> getInteraction + +-- |Get the 'Request' value which represents the request header. In +-- general you don't have to use this action. +getRequest ∷ Resource Request +getRequest + = do itr ← getInteraction + liftIO $ atomically $ readItr itrRequest fromJust itr + +-- |Get the 'Method' value of the request. +getMethod ∷ Resource Method +getMethod = reqMethod <$> getRequest -- |Get the URI of the request. -getRequestURI :: Resource URI -getRequestURI = do req <- getRequest - return $! reqURI req +getRequestURI ∷ Resource URI +getRequestURI = reqURI <$> getRequest -- |Get the HTTP version of the request. -getRequestVersion :: Resource HttpVersion -getRequestVersion = do req <- getRequest - return $! reqVersion req +getRequestVersion ∷ Resource HttpVersion +getRequestVersion = reqVersion <$> getRequest -- |Get the path of this 'Resource' (to be exact, -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the @@ -273,141 +264,155 @@ getRequestVersion = do req <- getRequest -- > -- > resFoo = ResourceDef { -- > resIsGreedy = True --- > , resGet = Just $ do requestURI <- getRequestURI --- > resourcePath <- getResourcePath --- > pathInfo <- getPathInfo +-- > , resGet = Just $ do requestURI ← getRequestURI +-- > resourcePath ← getResourcePath +-- > pathInfo ← getPathInfo -- > -- uriPath requestURI == "/foo/bar/baz" -- > -- resourcePath == ["foo"] -- > -- pathInfo == ["bar", "baz"] -- > ... -- > , ... -- > } -getResourcePath :: Resource [String] -getResourcePath = do itr <- getInteraction - return $! fromJust $! itrResourcePath itr - +getResourcePath ∷ Resource [Ascii] +getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction -- |This is an analogy of CGI PATH_INFO. The result is -- URI-unescaped. It is always @[]@ if the -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See -- 'getResourcePath'. -getPathInfo :: Resource [String] -getPathInfo = do rsrcPath <- getResourcePath - uri <- getRequestURI +getPathInfo ∷ Resource [ByteString] +getPathInfo = do rsrcPath ← getResourcePath + uri ← getRequestURI let reqPathStr = uriPath uri - reqPath = [unEscapeString x | x <- splitBy (== '/') reqPathStr, x /= ""] + reqPath = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)] -- rsrcPath と reqPath の共通する先頭部分を reqPath か -- ら全部取り除くと、それは PATH_INFO のやうなものにな -- る。rsrcPath は全部一致してゐるに決まってゐる（でな -- ければこの Resource が撰ばれた筈が無い）ので、 -- rsrcPath の長さの分だけ削除すれば良い。 - return $! drop (length rsrcPath) reqPath + return $ map C8.pack $ drop (length rsrcPath) reqPath -- |Assume the query part of request URI as -- application\/x-www-form-urlencoded, and parse it to pairs of -- @(name, formData)@. This action doesn't parse the request body. See --- 'inputForm'. -getQueryForm :: Resource [(String, FormData)] -getQueryForm = liftM parse' getRequestURI +-- 'inputForm'. Field names are decoded in UTF-8. +getQueryForm ∷ Resource [(Text, FormData)] +getQueryForm = parse' <$> getRequestURI where - parse' = map toPairWithFormData . - parseWWWFormURLEncoded . - snd . - splitAt 1 . + parse' = map toPairWithFormData ∘ + parseWWWFormURLEncoded ∘ + fromJust ∘ + A.fromChars ∘ + drop 1 ∘ uriQuery -toPairWithFormData :: (String, String) -> (String, FormData) +toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData) toPairWithFormData (name, value) = let fd = FormData { fdFileName = Nothing - , fdContent = L8.pack value + , fdContent = L8.fromChunks [value] } - in (name, fd) + in (T.decodeUtf8With T.lenientDecode name, fd) -- |Get a value of given request header. Comparison of header name is -- 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 :: Strict.ByteString -> Resource (Maybe Strict.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 (C8.pack "Accept") - case acceptM of - Nothing - -> return [] - Just accept - -> case parse mimeTypeListP (L8.fromChunks [accept]) of - (# Success xs, _ #) -> return xs - (# _ , _ #) -> abort BadRequest [] - (Just $ "Unparsable Accept: " ++ C8.unpack accept) +getHeader ∷ CIAscii → Resource (Maybe Ascii) +getHeader name + = H.getHeader name <$> getRequest + +-- |Get a list of 'MIMEType' enumerated on header \"Accept\". +getAccept ∷ Resource [MIMEType] +getAccept + = do acceptM ← getHeader "Accept" + case acceptM of + Nothing + → return [] + Just accept + → case P.parseOnly p (A.toByteString accept) of + Right xs → return xs + Left _ → abort BadRequest [] + (Just $ "Unparsable Accept: " ⊕ A.toText accept) + where + p = do xs ← mimeTypeListP + P.endOfInput + return xs -- |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 ∷ Resource [(CIAscii, Maybe Double)] getAcceptEncoding - = do accEncM <- getHeader (C8.pack "Accept-Encoding") + = do accEncM ← getHeader "Accept-Encoding" case accEncM of Nothing -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い -- ので安全の爲 identity が指定された事にする。HTTP/1.1 -- の場合は何でも受け入れて良い事になってゐるので "*" が -- 指定された事にする。 - -> do ver <- getRequestVersion - case ver of - HttpVersion 1 0 -> return [("identity", Nothing)] - HttpVersion 1 1 -> return [("*" , Nothing)] - _ -> undefined - Just value - -> if C8.null value then + → do ver ← getRequestVersion + case ver of + HttpVersion 1 0 → return [("identity", Nothing)] + HttpVersion 1 1 → return [("*" , Nothing)] + _ → abort InternalServerError [] + (Just "getAcceptEncoding: unknown HTTP version") + Just ae + → if ae ≡ "" then -- identity のみが許される。 return [("identity", Nothing)] else - case parse acceptEncodingListP (L8.fromChunks [value]) of - (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x - (# _ , _ #) -> abort BadRequest [] - (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value) + case P.parseOnly p (A.toByteString ae) of + Right xs → return $ map toTuple $ reverse $ sort xs + Left _ → abort BadRequest [] + (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae) + where + p = do xs ← acceptEncodingListP + P.endOfInput + return xs --- |Check whether a given content-coding is acceptable. -isEncodingAcceptable :: String -> Resource Bool -isEncodingAcceptable coding - = do accList <- getAcceptEncoding - return (flip any accList $ \ (c, q) -> - (c == "*" || C8.pack c `H.noCaseEq` C8.pack coding) && q /= Just 0) + toTuple (AcceptEncoding {..}) + = (aeEncoding, aeQValue) +-- |Check whether a given content-coding is acceptable. +isEncodingAcceptable ∷ CIAscii → Resource Bool +isEncodingAcceptable encoding = any f <$> getAcceptEncoding + where + f (e, q) + = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0 --- |Get the header \"Content-Type\" as --- 'Network.HTTP.Lucu.MIMEType.MIMEType'. -getContentType :: Resource (Maybe MIMEType) +-- |Get the header \"Content-Type\" as 'MIMEType'. +getContentType ∷ Resource (Maybe MIMEType) getContentType - = do cTypeM <- getHeader (C8.pack "Content-Type") + = do cTypeM ← getHeader "Content-Type" case cTypeM of Nothing - -> return Nothing + → return Nothing Just cType - -> case parse mimeTypeP (L8.fromChunks [cType]) of - (# Success t, _ #) -> return $ Just t - (# _ , _ #) -> abort BadRequest [] - (Just $ "Unparsable Content-Type: " ++ C8.unpack cType) - + → case P.parseOnly p (A.toByteString cType) of + Right t → return $ Just t + Left _ → abort BadRequest [] + (Just $ "Unparsable Content-Type: " ⊕ A.toText cType) + where + p = do t ← mimeTypeP + P.endOfInput + return t --- |Get the header \"Authorization\" as --- 'Network.HTTP.Lucu.Authorization.AuthCredential'. -getAuthorization :: Resource (Maybe AuthCredential) +-- |Get the header \"Authorization\" as 'AuthCredential'. +getAuthorization ∷ Resource (Maybe AuthCredential) getAuthorization - = do authM <- getHeader (C8.pack "Authorization") + = do authM ← getHeader "Authorization" case authM of Nothing - -> return Nothing + → return Nothing Just auth - -> case parse authCredentialP (L8.fromChunks [auth]) of - (# Success a, _ #) -> return $ Just a - (# _ , _ #) -> return Nothing + → case P.parseOnly p (A.toByteString auth) of + Right ac → return $ Just ac + Left _ → return Nothing + where + p = do ac ← authCredentialP + P.endOfInput + return ac {- ExaminingRequest 時に使用するアクション群 -} @@ -426,17 +431,16 @@ getAuthorization -- -- If this is a GET or HEAD request, 'foundEntity' automatically puts -- \"ETag\" and \"Last-Modified\" headers into the response. -foundEntity :: ETag -> UTCTime -> Resource () -foundEntity tag timeStamp - = tag `seq` timeStamp `seq` - do driftTo ExaminingRequest - - method <- getMethod - when (method == GET || method == HEAD) - $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp) - when (method == POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundEntity for a POST request.") +foundEntity ∷ ETag → UTCTime → Resource () +foundEntity !tag !timeStamp + = do driftTo ExaminingRequest + + method ← getMethod + when (method ≡ GET ∨ method ≡ HEAD) + $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp) + when (method ≡ POST) + $ abort InternalServerError [] + (Just "Illegal computation of foundEntity for a POST request.") foundETag tag driftTo GettingBody @@ -448,55 +452,61 @@ foundEntity tag timeStamp -- -- This action is not preferred. You should use 'foundEntity' whenever -- possible. -foundETag :: ETag -> Resource () -foundETag tag - = tag `seq` - do driftTo ExaminingRequest +foundETag ∷ ETag → Resource () +foundETag !tag + = do driftTo ExaminingRequest - method <- getMethod - when (method == GET || method == HEAD) - $ setHeader' (C8.pack "ETag") (C8.pack $ show tag) - when (method == POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundETag for POST request.") + method ← getMethod + when (method ≡ GET ∨ method ≡ HEAD) + $ setHeader' "ETag" (printETag tag) + when (method ≡ POST) + $ abort InternalServerError [] + (Just "Illegal computation of foundETag for POST request.") -- If-Match があればそれを見る。 - ifMatch <- getHeader (C8.pack "If-Match") + ifMatch ← getHeader "If-Match" case ifMatch of - Nothing -> return () - Just value -> if value == C8.pack "*" then - return () - else - case parse eTagListP (L8.fromChunks [value]) of - (# Success tags, _ #) + Nothing → return () + Just value → if value ≡ "*" then + return () + else + case P.parseOnly p (A.toByteString value) of + Right 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 - else - PreconditionFailed + → when ((¬) (any (≡ tag) tags)) + $ abort PreconditionFailed [] + (Just $ "The entity tag doesn't match: " ⊕ A.toText value) + Left _ + → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value) + + let statusForNoneMatch + = if method ≡ GET ∨ method ≡ HEAD then + NotModified + else + PreconditionFailed -- If-None-Match があればそれを見る。 - ifNoneMatch <- getHeader (C8.pack "If-None-Match") + ifNoneMatch ← getHeader "If-None-Match" case ifNoneMatch of - Nothing -> return () - Just value -> if value == C8.pack "*" then - abort statusForNoneMatch [] $! Just ("The entity tag matches: *") + Nothing → return () + Just value → if value ≡ "*" then + abort statusForNoneMatch [] (Just "The entity tag matches: *") else - case parse eTagListP (L8.fromChunks [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) + case P.parseOnly p (A.toByteString value) of + Right tags + → when (any (≡ tag) tags) + $ abort statusForNoneMatch [] + (Just $ "The entity tag matches: " ⊕ A.toText value) + Left _ + → abort BadRequest [] + (Just $ "Unparsable If-None-Match: " ⊕ A.toText value) driftTo GettingBody + where + p = do xs ← eTagListP + P.endOfInput + return xs -- |Tell the system that the 'Resource' found an entity for the -- request URI. The only difference from 'foundEntity' is that @@ -508,46 +518,46 @@ foundETag tag -- -- This action is not preferred. You should use 'foundEntity' whenever -- possible. -foundTimeStamp :: UTCTime -> Resource () +foundTimeStamp ∷ UTCTime → Resource () foundTimeStamp timeStamp - = timeStamp `seq` - do driftTo ExaminingRequest + = do driftTo ExaminingRequest - method <- getMethod - when (method == GET || method == HEAD) - $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp) - when (method == POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundTimeStamp for POST request.") + method ← getMethod + when (method ≡ GET ∨ method ≡ HEAD) + $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp) + when (method ≡ POST) + $ abort InternalServerError [] + (Just "Illegal computation of foundTimeStamp for POST request.") - let statusForIfModSince = if method == GET || method == HEAD then - NotModified - else - PreconditionFailed + let statusForIfModSince + = if method ≡ GET ∨ method ≡ HEAD then + NotModified + else + PreconditionFailed -- If-Modified-Since があればそれを見る。 - ifModSince <- getHeader (C8.pack "If-Modified-Since") + ifModSince ← getHeader "If-Modified-Since" case ifModSince of - Just str -> case HTTP.parse (C8.unpack str) of - Just lastTime - -> when (timeStamp <= lastTime) - $ abort statusForIfModSince [] - $! Just ("The entity has not been modified since " ++ C8.unpack str) - Nothing - -> return () -- 不正な時刻は無視 - Nothing -> return () + Just str → case HTTP.fromAscii str of + Right lastTime + → when (timeStamp ≤ lastTime) + $ abort statusForIfModSince [] + (Just $ "The entity has not been modified since " ⊕ A.toText str) + Left _ + → return () -- 不正な時刻は無視 + Nothing → return () -- If-Unmodified-Since があればそれを見る。 - ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since") + ifUnmodSince ← getHeader "If-Unmodified-Since" case ifUnmodSince of - Just str -> case HTTP.parse (C8.unpack str) of - Just lastTime - -> when (timeStamp > lastTime) - $ abort PreconditionFailed [] - $! Just ("The entity has not been modified since " ++ C8.unpack str) - Nothing - -> return () -- 不正な時刻は無視 - Nothing -> return () + Just str → case HTTP.fromAscii str of + Right lastTime + → when (timeStamp > lastTime) + $ abort PreconditionFailed [] + (Just $ "The entity has not been modified since " ⊕ A.toText str) + Left _ + → return () -- 不正な時刻は無視 + Nothing → return () driftTo GettingBody @@ -559,20 +569,19 @@ foundTimeStamp timeStamp -- test and aborts with status \"412 Precondition Failed\" when it -- failed. If this is a GET, HEAD, POST or DELETE request, -- 'foundNoEntity' always aborts with status \"404 Not Found\". -foundNoEntity :: Maybe String -> Resource () +foundNoEntity ∷ Maybe Text → Resource () foundNoEntity msgM - = msgM `seq` - do driftTo ExaminingRequest + = do driftTo ExaminingRequest - method <- getMethod - when (method /= PUT) - $ abort NotFound [] msgM + method ← getMethod + when (method ≢ PUT) + $ abort NotFound [] msgM -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 - ifMatch <- getHeader (C8.pack "If-Match") - when (ifMatch /= Nothing) - $ abort PreconditionFailed [] msgM + ifMatch ← getHeader "If-Match" + when (ifMatch ≢ Nothing) + $ abort PreconditionFailed [] msgM driftTo GettingBody @@ -587,82 +596,68 @@ foundNoEntity msgM -- no body, 'input' returns an empty string. -- -- @limit@ may be less than or equal to zero. In this case, the --- default limitation value --- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See +-- default limitation value ('cnfMaxEntityLength') is used. See -- 'defaultLimit'. -- --- Note that 'inputLBS' is more efficient than 'input' so you should --- use it whenever possible. -input :: Int -> Resource String -input limit = limit `seq` - inputLBS limit >>= return . L8.unpack - - --- | This is mostly the same as 'input' but is more --- efficient. 'inputLBS' returns a 'Data.ByteString.Lazy.ByteString' --- 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.Lazy.ByteString'. The same goes for --- 'inputChunkLBS'. -inputLBS :: Int -> Resource Lazy.ByteString -inputLBS limit - = limit `seq` - do driftTo GettingBody - itr <- getInteraction - hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id - chunk <- if hasBody then - askForInput itr - else - do driftTo DecidingHeader - return L8.empty +-- 'input' returns a 'Lazy.ByteString' but it's not really lazy: +-- reading from the socket just happens at the computation of 'input', +-- not at the evaluation of the 'Lazy.ByteString'. The same goes for +-- 'inputChunk'. +input ∷ Int → Resource Lazy.ByteString +input limit + = do driftTo GettingBody + itr ← getInteraction + hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr + chunk ← if hasBody then + askForInput itr + else + do driftTo DecidingHeader + return L8.empty return chunk where - askForInput :: Interaction -> Resource Lazy.ByteString + askForInput ∷ Interaction → Resource Lazy.ByteString askForInput itr - = itr `seq` - do let confLimit = cnfMaxEntityLength $ itrConfig itr - actualLimit = if limit <= 0 then + = do let confLimit = cnfMaxEntityLength $ itrConfig itr + actualLimit = if limit ≤ 0 then confLimit else limit - when (actualLimit <= 0) - $ fail ("inputLBS: limit must be positive: " ++ show actualLimit) + when (actualLimit ≤ 0) + $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit) -- Reader にリクエスト - liftIO $! atomically - $! do chunkLen <- readItr itr itrReqChunkLength id - writeItr itr itrWillReceiveBody True - if fmap (> actualLimit) chunkLen == Just True then - -- 受信前から多過ぎる事が分かってゐる - tooLarge actualLimit - else - writeItr itr itrReqBodyWanted $ Just actualLimit - -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 - chunk <- liftIO $! atomically - $! do chunk <- readItr itr itrReceivedBody id - chunkIsOver <- readItr itr itrReqChunkIsOver id - if L8.length chunk < fromIntegral actualLimit then - -- 要求された量に滿たなくて、まだ殘り - -- があるなら再試行。 - unless chunkIsOver - $ retry - else - -- 制限値一杯まで讀むやうに指示したの - -- にまだ殘ってゐるなら、それは多過ぎ - -- る。 - unless chunkIsOver - $ tooLarge actualLimit - -- 成功。itr 内にチャンクを置いたままにす - -- るとメモリの無駄になるので除去。 - writeItr itr itrReceivedBody L8.empty - return chunk + liftIO $ atomically + $ do chunkLen ← readItr itrReqChunkLength id itr + writeItr itrWillReceiveBody True itr + if fmap (> actualLimit) chunkLen ≡ Just True then + -- 受信前から多過ぎる事が分かってゐる + tooLarge actualLimit + else + writeItr itrReqBodyWanted (Just actualLimit) itr + -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。 + chunk ← liftIO $ atomically + $ do chunk ← readItr itrReceivedBody chunksToLBS itr + chunkIsOver ← readItr itrReqChunkIsOver id itr + if L8.length chunk < fromIntegral actualLimit then + -- 要求された量に滿たなくて、まだ殘りが + -- あるなら再試行。 + unless chunkIsOver + $ retry + else + -- 制限値一杯まで讀むやうに指示したのに + -- まだ殘ってゐるなら、それは多過ぎる。 + unless chunkIsOver + $ tooLarge actualLimit + -- 成功。itr 内にチャンクを置いたままにする + -- とメモリの無駄になるので除去。 + writeItr itrReceivedBody (∅) itr + return chunk driftTo DecidingHeader return chunk - tooLarge :: Int -> STM () - tooLarge lim = lim `seq` - abortSTM RequestEntityTooLarge [] - $! Just ("Request body must be smaller than " - ++ show lim ++ " bytes.") + tooLarge ∷ Int → STM () + tooLarge lim = abortSTM RequestEntityTooLarge [] + (Just $ "Request body must be smaller than " + ⊕ T.pack (show lim) ⊕ " bytes.") -- | Computation of @'inputChunk' limit@ attempts to read a part of -- request body up to @limit@ bytes. You can read any large request by @@ -671,36 +666,26 @@ inputLBS limit -- the 'Resource' transit to /Deciding Header/ state. -- -- @limit@ may be less than or equal to zero. In this case, the --- default limitation value --- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See +-- default limitation value ('cnfMaxEntityLength') is used. See -- 'defaultLimit'. -- -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you -- should use it whenever possible. -inputChunk :: Int -> Resource String -inputChunk limit = limit `seq` - inputChunkLBS limit >>= return . L8.unpack - - --- | This is mostly the same as 'inputChunk' but is more --- efficient. See 'inputLBS'. -inputChunkLBS :: Int -> Resource Lazy.ByteString -inputChunkLBS limit - = limit `seq` - do driftTo GettingBody - itr <- getInteraction - hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id - chunk <- if hasBody then +inputChunk ∷ Int → Resource Lazy.ByteString +inputChunk limit + = do driftTo GettingBody + itr ← getInteraction + hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr + chunk ← if hasBody then askForInput itr else do driftTo DecidingHeader return L8.empty return chunk where - askForInput :: Interaction -> Resource Lazy.ByteString + askForInput ∷ Interaction → Resource Lazy.ByteString askForInput itr - = itr `seq` - do let confLimit = cnfMaxEntityLength $! itrConfig itr + = do let confLimit = cnfMaxEntityLength $ itrConfig itr actualLimit = if limit < 0 then confLimit else @@ -708,23 +693,23 @@ inputChunkLBS limit when (actualLimit <= 0) $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト - liftIO $! atomically - $! do writeItr itr itrReqBodyWanted $! Just actualLimit - writeItr itr itrWillReceiveBody True + liftIO $ atomically + $ do writeItr itrReqBodyWanted (Just actualLimit) itr + writeItr itrWillReceiveBody True itr -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 - chunk <- liftIO $! atomically - $ do chunk <- readItr itr itrReceivedBody id + chunk ← liftIO $ atomically + $ do chunk ← readItr itrReceivedBody chunksToLBS itr -- 要求された量に滿たなくて、まだ殘りがあ -- るなら再試行。 when (L8.length chunk < fromIntegral actualLimit) - $ do chunkIsOver <- readItr itr itrReqChunkIsOver id + $ do chunkIsOver ← readItr itrReqChunkIsOver id itr unless chunkIsOver - $ retry + $ retry -- 成功 - writeItr itr itrReceivedBody L8.empty + writeItr itrReceivedBody (∅) itr return chunk when (L8.null chunk) - $ driftTo DecidingHeader + $ driftTo DecidingHeader return chunk -- | Computation of @'inputForm' limit@ attempts to read the request @@ -734,57 +719,69 @@ inputChunkLBS limit -- makes 'Resource' abort with status \"415 Unsupported Media -- Type\". If the request has no \"Content-Type\", it aborts with -- \"400 Bad Request\". -inputForm :: Int -> Resource [(String, FormData)] +inputForm ∷ Int → Resource [(Text, FormData)] inputForm limit - = limit `seq` - do cTypeM <- getContentType + = do cTypeM ← getContentType case cTypeM of Nothing - -> abort BadRequest [] (Just "Missing Content-Type") + → abort BadRequest [] (Just "Missing Content-Type") Just (MIMEType "application" "x-www-form-urlencoded" _) - -> readWWWFormURLEncoded + → readWWWFormURLEncoded Just (MIMEType "multipart" "form-data" params) - -> readMultipartFormData params + → readMultipartFormData params Just cType - -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: " - ++ show cType) + → abort UnsupportedMediaType [] + (Just $ "Unsupported media type: " ⊕ A.toText (printMIMEType cType)) where readWWWFormURLEncoded - = liftM (map toPairWithFormData . parseWWWFormURLEncoded) (input limit) + = (map toPairWithFormData ∘ parseWWWFormURLEncoded) + <$> + (bsToAscii =≪ input limit) + + bsToAscii bs + = case A.fromByteString (C8.concat (L8.toChunks bs)) of + Just a → return a + Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded") readMultipartFormData params - = do case find ((== "boundary") . map toLower . fst) params of + = do case M.lookup "boundary" params of Nothing - -> abort BadRequest [] (Just "Missing boundary of multipart/form-data") - Just (_, boundary) - -> do src <- inputLBS limit - case parse (multipartFormP boundary) src of - (# Success formList, _ #) - -> return formList - (# _, _ #) - -> abort BadRequest [] (Just "Unparsable multipart/form-data") + → abort BadRequest [] (Just "Missing boundary of multipart/form-data") + Just boundary + → do src ← input limit + b ← case A.fromText boundary of + Just b → return b + Nothing → abort BadRequest [] + (Just $ "Malformed boundary: " ⊕ boundary) + case LP.parse (p b) src of + LP.Done _ formList + → return formList + _ → abort BadRequest [] (Just "Unparsable multipart/form-data") + where + p b = do xs ← multipartFormP b + P.endOfInput + return xs -- | 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 +defaultLimit ∷ Int defaultLimit = (-1) - {- DecidingHeader 時に使用するアクション群 -} -- | Set the response status code. If you omit to compute this action, -- the status code will be defaulted to \"200 OK\". -setStatus :: StatusCode -> Resource () +setStatus ∷ StatusCode → Resource () setStatus code - = code `seq` - do driftTo DecidingHeader - itr <- getInteraction - liftIO $! atomically $! updateItr itr itrResponse - $! \ res -> res { - resStatus = code - } + = do driftTo DecidingHeader + itr ← getInteraction + liftIO $ atomically $ updateItr itrResponse f itr + where + f res = res { + resStatus = code + } -- | Set a value of given resource header. Comparison of header name -- is case-insensitive. Note that this action is not intended to be @@ -800,62 +797,64 @@ setStatus code -- 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 :: Strict.ByteString -> Strict.ByteString -> Resource () +setHeader ∷ CIAscii → Ascii → Resource () setHeader name value - = name `seq` value `seq` - driftTo DecidingHeader >> setHeader' name value - + = driftTo DecidingHeader ≫ setHeader' name value -setHeader' :: Strict.ByteString -> Strict.ByteString -> Resource () +setHeader' ∷ CIAscii → Ascii → Resource () setHeader' name value - = name `seq` value `seq` - do itr <- getInteraction + = do itr ← getInteraction liftIO $ atomically - $ updateItr itr itrResponse - $ H.setHeader name value + $ updateItr itrResponse (H.setHeader name value) itr -- | Computation of @'redirect' code uri@ sets the response status to -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy --- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error. -redirect :: StatusCode -> URI -> Resource () +-- 'isRedirection' or it causes an error. +redirect ∷ StatusCode → URI → Resource () redirect code uri - = code `seq` uri `seq` - do when (code == NotModified || not (isRedirection code)) - $ abort InternalServerError [] - $! Just ("Attempted to redirect with status " ++ show code) + = do when (code ≡ NotModified ∨ not (isRedirection code)) + $ abort InternalServerError [] + (Just $ "Attempted to redirect with status " ⊕ A.toText (printStatusCode code)) setStatus code setLocation uri -{-# INLINE redirect #-} - -- | Computation of @'setContentType' mType@ sets the response header -- \"Content-Type\" to @mType@. -setContentType :: MIMEType -> Resource () +setContentType ∷ MIMEType → Resource () setContentType mType - = setHeader (C8.pack "Content-Type") (C8.pack $ show mType) + = setHeader "Content-Type" (printMIMEType mType) -- | Computation of @'setLocation' uri@ sets the response header -- \"Location\" to @uri@. -setLocation :: URI -> Resource () +setLocation ∷ URI → Resource () setLocation uri - = setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "") + = case A.fromChars uriStr of + Just a → setHeader "Location" a + Nothing → abort InternalServerError [] + (Just $ "Malformed URI: " ⊕ T.pack uriStr) + where + uriStr = uriToString id uri "" -- |Computation of @'setContentEncoding' codings@ sets the response -- header \"Content-Encoding\" to @codings@. -setContentEncoding :: [String] -> Resource () +setContentEncoding ∷ [CIAscii] → Resource () setContentEncoding codings - = do ver <- getRequestVersion - let tr = case ver of - HttpVersion 1 0 -> unnormalizeCoding - HttpVersion 1 1 -> id - _ -> undefined - setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings) + = do ver ← getRequestVersion + tr ← case ver of + HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding) + HttpVersion 1 1 → return toAB + _ → abort InternalServerError [] + (Just "setContentEncoding: Unknown HTTP version") + setHeader "Content-Encoding" + (A.fromAsciiBuilder $ joinWith ", " $ map tr codings) + where + toAB = A.toAsciiBuilder ∘ A.fromCIAscii -- |Computation of @'setWWWAuthenticate' challenge@ sets the response -- header \"WWW-Authenticate\" to @challenge@. -setWWWAuthenticate :: AuthChallenge -> Resource () +setWWWAuthenticate ∷ AuthChallenge → Resource () setWWWAuthenticate challenge - = setHeader (C8.pack "WWW-Authenticate") (C8.pack $ show challenge) + = setHeader "WWW-Authenticate" (printAuthChallenge challenge) {- DecidingBody 時に使用するアクション群 -} @@ -864,70 +863,53 @@ setWWWAuthenticate challenge -- and then make the 'Resource' transit to /Done/ state. It is safe to -- apply 'output' to an infinite string, such as a lazy stream of -- \/dev\/random. --- --- Note that 'outputLBS' is more efficient than 'output' so you should --- use it whenever possible. -output :: String -> Resource () -output str = outputLBS $! L8.pack str +output ∷ Lazy.ByteString → Resource () {-# INLINE output #-} - --- | This is mostly the same as 'output' but is more efficient. -outputLBS :: Lazy.ByteString -> Resource () -outputLBS str = do outputChunkLBS str - driftTo Done -{-# INLINE outputLBS #-} +output str = do outputChunk str + driftTo Done -- | 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 'outputChunkLBS' is more efficient than 'outputChunk' so --- you should use it whenever possible. -outputChunk :: String -> Resource () -outputChunk str = outputChunkLBS $! L8.pack str -{-# INLINE outputChunk #-} - --- | This is mostly the same as 'outputChunk' but is more efficient. -outputChunkLBS :: Lazy.ByteString -> Resource () -outputChunkLBS wholeChunk - = wholeChunk `seq` - do driftTo DecidingBody - itr <- getInteraction +outputChunk ∷ Lazy.ByteString → Resource () +outputChunk wholeChunk + = do driftTo DecidingBody + itr ← getInteraction let limit = cnfMaxOutputChunkLength $ itrConfig itr - when (limit <= 0) - $ fail ("cnfMaxOutputChunkLength must be positive: " - ++ show limit) + when (limit ≤ 0) + $ abort InternalServerError [] + (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit)) - discardBody <- liftIO $ atomically $ - readItr itr itrWillDiscardBody id + discardBody ← liftIO $ atomically $ + readItr itrWillDiscardBody id itr unless (discardBody) - $ sendChunks wholeChunk limit + $ sendChunks wholeChunk limit unless (L8.null wholeChunk) - $ liftIO $ atomically $ - writeItr itr itrBodyIsNull False + $ liftIO $ atomically $ + writeItr itrBodyIsNull False itr where -- チャンクの大きさは Config で制限されてゐる。もし例へば -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま -- ResponseWriter に渡したりすると大變な事が起こる。何故なら -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書 - -- く爲にチャンクの大きさを測る。 - sendChunks :: Lazy.ByteString -> Int -> Resource () + -- く爲にチャンクの大きさを測るからだ。 + sendChunks ∷ Lazy.ByteString → Int → Resource () sendChunks str limit | L8.null str = return () | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str - itr <- getInteraction + itr ← getInteraction liftIO $ atomically $ - do buf <- readItr itr itrBodyToSend id - if L8.null buf then - -- バッファが消化された - writeItr itr itrBodyToSend chunk - else - -- 消化されるのを待つ - retry + do buf ← readItr itrBodyToSend id itr + if S.null buf then + -- バッファが消化された + writeItr itrBodyToSend (chunksFromLBS chunk) itr + else + -- 消化されるのを待つ + retry -- 殘りのチャンクについて繰り返す sendChunks remaining limit @@ -950,11 +932,10 @@ outputChunkLBS wholeChunk -} -driftTo :: InteractionState -> Resource () +driftTo ∷ InteractionState → Resource () driftTo newState - = newState `seq` - do itr <- getInteraction - liftIO $ atomically $ do oldState <- readItr itr itrState id + = do itr ← getInteraction + liftIO $ atomically $ do oldState ← readItr itrState id itr if newState < oldState then throwStateError oldState newState else @@ -962,27 +943,27 @@ driftTo newState b = tail a c = zip a b mapM_ (uncurry $ drift itr) c - writeItr itr itrState newState + writeItr itrState newState itr where - throwStateError :: Monad m => InteractionState -> InteractionState -> m a + throwStateError ∷ Monad m => InteractionState → InteractionState → m a throwStateError Done DecidingBody = fail "It makes no sense to output something after finishing to output." throwStateError old new - = fail ("state error: " ++ show old ++ " ==> " ++ show new) + = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new) - drift :: Interaction -> InteractionState -> InteractionState -> STM () + drift ∷ Interaction → InteractionState → InteractionState → STM () drift itr GettingBody _ - = writeItr itr itrReqBodyWasteAll True + = writeItr itrReqBodyWasteAll True itr drift itr DecidingHeader _ = postprocess itr drift itr _ Done - = do bodyIsNull <- readItr itr itrBodyIsNull id + = do bodyIsNull ← readItr itrBodyIsNull id itr when bodyIsNull $ writeDefaultPage itr diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index 2791616..df98bf7 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -27,10 +27,10 @@ import Data.Ascii (Ascii) import qualified Data.Ascii as A 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 Network.HTTP.Lucu.Utils import Prelude.Unicode -- |This is the definition of HTTP status code. @@ -93,7 +93,7 @@ data StatusCode = Continue printStatusCode ∷ StatusCode → Ascii printStatusCode (statusCode → (# num, msg #)) = A.fromAsciiBuilder $ - ( fmtDec 3 num ⊕ + ( show3 num ⊕ A.toAsciiBuilder " " ⊕ A.toAsciiBuilder msg ) @@ -118,7 +118,7 @@ hPutResponse h (Response {..}) hPutStatus ∷ HandleLike h ⇒ h → StatusCode → IO () hPutStatus h (statusCode → (# num, msg #)) - = do hPutBS h (A.toByteString $ A.fromAsciiBuilder $ fmtDec 3 num) + = do hPutBS h (A.toByteString $ A.fromAsciiBuilder $ show3 num) hPutChar h ' ' hPutBS h (A.toByteString msg) diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index d254169..ec4b672 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -10,11 +10,15 @@ module Network.HTTP.Lucu.Utils , joinWith , quoteStr , parseWWWFormURLEncoded + , show3 ) where +import Blaze.ByteString.Builder.ByteString as B +import Blaze.Text.Int as BT import Control.Monad import Data.Ascii (Ascii, AsciiBuilder) import qualified Data.Ascii as A +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.List hiding (last) import Data.Monoid.Unicode @@ -65,10 +69,12 @@ quoteStr str = A.toAsciiBuilder "\"" ⊕ -- |> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd" -- > ==> [("aaa", "bbb"), ("ccc", "ddd")] -parseWWWFormURLEncoded ∷ String → [(String, String)] +parseWWWFormURLEncoded ∷ Ascii → [(ByteString, ByteString)] parseWWWFormURLEncoded src - | null src = [] - | otherwise = do pairStr ← splitBy (\ c → c ≡ ';' ∨ c ≡ '&') src + -- THINKME: We could gain some performance by using attoparsec + -- here. + | src ≡ "" = [] + | otherwise = do pairStr ← splitBy (\ c → c ≡ ';' ∨ c ≡ '&') (A.toString src) let (key, value) = break (≡ '=') pairStr return ( unescape key , unescape $ case value of @@ -76,9 +82,20 @@ parseWWWFormURLEncoded src val → val ) where - unescape ∷ String → String - unescape = unEscapeString ∘ map plusToSpace + unescape ∷ String → ByteString + unescape = BS.pack ∘ unEscapeString ∘ map plusToSpace plusToSpace ∷ Char → Char plusToSpace '+' = ' ' plusToSpace c = c + +-- |> show3 5 +-- > ==> "005" +show3 ∷ Integral n ⇒ n → AsciiBuilder +{-# INLINEABLE show3 #-} +show3 = A.unsafeFromBuilder ∘ go + where + go i | i ≥ 0 ∧ i < 10 = B.fromByteString "00" ⊕ BT.digit i + | i ≥ 0 ∧ i < 100 = B.fromByteString "0" ⊕ BT.integral i + | i ≥ 0 ∧ i < 1000 = BT.integral i + | otherwise = error ("show3: the integer i must satisfy 0 <= i < 1000: " ⧺ show i) -- 2.40.0