From: PHO Date: Mon, 31 Oct 2011 15:22:48 +0000 (+0900) Subject: Reimplement MultipartForm X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=a362be1;p=Lucu.git Reimplement MultipartForm Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- diff --git a/ImplantFile.hs b/ImplantFile.hs index c3cff03..c253c2a 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -106,13 +106,13 @@ main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs generateHaskellSource ∷ [CmdOpt] → FilePath → IO () generateHaskellSource opts srcFile - = do modName ← getModuleName opts - symName ← getSymbolName opts modName - mimeType ← getMIMEType opts srcFile - lastMod ← getLastModified srcFile - input ← openInput srcFile - output ← openOutput opts - eTag ← getETag opts input + = do modName ← getModuleName opts + symName ← getSymbolName opts modName + mType ← getMIMEType opts srcFile + lastMod ← getLastModified srcFile + input ← openInput srcFile + output ← openOutput opts + tag ← getETag opts input let compParams = defaultCompressParams { compressLevel = bestCompression } gzippedData = compressWith compParams input @@ -122,14 +122,14 @@ generateHaskellSource opts srcFile rawB64 = B64.encode <$> Lazy.toChunks input gzippedB64 = B64.encode <$> Lazy.toChunks gzippedData - header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod + header ← mkHeader srcFile originalLen gzippedLen useGZip mType tag lastMod let hsModule = mkModule modName symName imports decls imports = mkImports useGZip decls = concat [ resourceDecl symName useGZip - , entityTagDecl eTag + , entityTagDecl tag , lastModifiedDecl lastMod - , contentTypeDecl mimeType + , contentTypeDecl mType , if useGZip then dataDecl (name "gzippedData") gzippedB64 else @@ -257,7 +257,7 @@ putChunksStmt ∷ Exp → Stmt putChunksStmt = qualStmt ∘ putChunksExp entityTagDecl ∷ ETag → [Decl] -entityTagDecl eTag +entityTagDecl tag = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag"))) , nameBind (⊥) varName valExp ] @@ -266,7 +266,7 @@ entityTagDecl eTag varName = name "entityTag" valExp ∷ Exp - valExp = function "parseETag" `app` strE (eTagToString eTag) + valExp = function "parseETag" `app` strE (eTagToString tag) lastModifiedDecl ∷ UTCTime → [Decl] lastModifiedDecl lastMod @@ -316,7 +316,7 @@ dataDecl varName chunks strE (Strict.unpack chunk) mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → ETag → UTCTime → IO String -mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod +mkHeader srcFile originalLen gzippedLen useGZip mType tag lastMod = do localLastMod ← utcToLocalZonedTime lastMod return $ concat [ "{- DO NOT EDIT THIS FILE.\n" @@ -333,8 +333,8 @@ mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod " Compression: gzip\n" else " Compression: disabled\n" - , " MIME Type: ", mimeTypeToString mimeType, "\n" - , " ETag: ", eTagToString eTag, "\n" + , " MIME Type: ", mimeTypeToString mType, "\n" + , " ETag: ", eTagToString tag, "\n" , " Last Modified: ", show localLastMod, "\n" , " -}" ] diff --git a/Lucu.cabal b/Lucu.cabal index dcfd832..46fabcf 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -63,10 +63,8 @@ Library mtl == 2.0.*, network == 2.3.*, stm == 2.2.*, - strict == 0.3.*, stringsearch == 0.3.*, text == 0.11.*, - text-icu == 0.6.*, time == 1.2.*, time-http == 0.2.*, transformers == 0.2.*, @@ -83,6 +81,7 @@ Library Network.HTTP.Lucu.MIMEType Network.HTTP.Lucu.MIMEType.DefaultExtensionMap Network.HTTP.Lucu.MIMEType.Guess + Network.HTTP.Lucu.MultipartForm Network.HTTP.Lucu.Parser.Http Network.HTTP.Lucu.Parser Network.HTTP.Lucu.RFC2231 @@ -101,7 +100,6 @@ Library Network.HTTP.Lucu.HandleLike Network.HTTP.Lucu.Headers Network.HTTP.Lucu.Interaction - Network.HTTP.Lucu.MultipartForm Network.HTTP.Lucu.Postprocess Network.HTTP.Lucu.Preprocess Network.HTTP.Lucu.RequestReader diff --git a/Network/HTTP/Lucu/Authentication.hs b/Network/HTTP/Lucu/Authentication.hs index 3f8d762..753af6e 100644 --- a/Network/HTTP/Lucu/Authentication.hs +++ b/Network/HTTP/Lucu/Authentication.hs @@ -11,7 +11,7 @@ module Network.HTTP.Lucu.Authentication , Password , printAuthChallenge - , authCredentialP + , authCredential ) where import Control.Monad @@ -55,8 +55,8 @@ printAuthChallenge (BasicAuthChallenge realm) A.toAsciiBuilder "Basic realm=" ⊕ quoteStr realm -- |'Parser' for an 'AuthCredential'. -authCredentialP ∷ Parser AuthCredential -authCredentialP +authCredential ∷ Parser AuthCredential +authCredential = do void $ string "Basic" skipMany1 lws b64 ← takeWhile1 base64 diff --git a/Network/HTTP/Lucu/Chunk.hs b/Network/HTTP/Lucu/Chunk.hs index b48727c..e8c9de4 100644 --- a/Network/HTTP/Lucu/Chunk.hs +++ b/Network/HTTP/Lucu/Chunk.hs @@ -2,9 +2,9 @@ UnicodeSyntax #-} module Network.HTTP.Lucu.Chunk - ( chunkHeaderP - , chunkFooterP - , chunkTrailerP + ( chunkHeader + , chunkFooter + , chunkTrailer ) where import Control.Applicative @@ -13,12 +13,12 @@ import Data.Bits import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.Parser.Http -chunkHeaderP ∷ (Integral a, Bits a) ⇒ Parser a -{-# INLINEABLE chunkHeaderP #-} -chunkHeaderP = do len ← hexadecimal - extension - crlf - return len +chunkHeader ∷ (Integral a, Bits a) ⇒ Parser a +{-# INLINEABLE chunkHeader #-} +chunkHeader = do len ← hexadecimal + extension + crlf + return len where extension ∷ Parser () extension @@ -27,8 +27,8 @@ chunkHeaderP = do len ← hexadecimal char '=' *> (token <|> quotedStr) ) -chunkFooterP ∷ Parser () -chunkFooterP = crlf +chunkFooter ∷ Parser () +chunkFooter = crlf -chunkTrailerP ∷ Parser Headers -chunkTrailerP = headersP +chunkTrailer ∷ Parser Headers +chunkTrailer = headers diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs index 3ce7806..a5f02b1 100644 --- a/Network/HTTP/Lucu/ContentCoding.hs +++ b/Network/HTTP/Lucu/ContentCoding.hs @@ -5,7 +5,7 @@ module Network.HTTP.Lucu.ContentCoding ( AcceptEncoding(..) - , acceptEncodingListP + , acceptEncodingList , normalizeCoding , unnormalizeCoding ) @@ -34,16 +34,16 @@ instance Ord AcceptEncoding where q1' = fromMaybe 0 q1 q2' = fromMaybe 0 q2 -acceptEncodingListP ∷ Parser [AcceptEncoding] -acceptEncodingListP = listOf accEncP +acceptEncodingList ∷ Parser [AcceptEncoding] +acceptEncodingList = listOf accEnc -accEncP ∷ Parser AcceptEncoding -accEncP = do coding ← toCIAscii <$> token - qVal ← option Nothing - $ do _ ← string ";q=" - q ← qvalue - return $ Just q - return $ AcceptEncoding (normalizeCoding coding) qVal +accEnc ∷ Parser AcceptEncoding +accEnc = do coding ← toCIAscii <$> token + qVal ← option Nothing + $ do _ ← string ";q=" + q ← qvalue + return $ Just q + return $ AcceptEncoding (normalizeCoding coding) qVal normalizeCoding ∷ CIAscii → CIAscii normalizeCoding coding diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs index d4a157f..76df183 100644 --- a/Network/HTTP/Lucu/ETag.hs +++ b/Network/HTTP/Lucu/ETag.hs @@ -10,8 +10,8 @@ module Network.HTTP.Lucu.ETag , strongETag , weakETag - , eTagP - , eTagListP + , eTag + , eTagList ) where import Control.Applicative @@ -58,7 +58,7 @@ parseETag str where p ∷ Parser ETag {-# INLINE p #-} - p = do et ← eTagP + p = do et ← eTag endOfInput return et @@ -75,16 +75,16 @@ weakETag ∷ Ascii → ETag weakETag = ETag True -- |'Parser' for an 'ETag'. -eTagP ∷ Parser ETag -{-# INLINEABLE eTagP #-} -eTagP = do isWeak ← option False (string "W/" *> return True) - str ← quotedStr - return $ ETag isWeak str +eTag ∷ Parser ETag +{-# INLINEABLE eTag #-} +eTag = do isWeak ← option False (string "W/" *> return True) + str ← quotedStr + return $ ETag isWeak str -- |'Parser' for a list of 'ETag's. -eTagListP ∷ Parser [ETag] -{-# INLINEABLE eTagListP #-} -eTagListP = do xs ← listOf eTagP - when (null xs) $ - fail "empty list of ETags" - return xs +eTagList ∷ Parser [ETag] +{-# INLINEABLE eTagList #-} +eTagList = do xs ← listOf eTag + when (null xs) $ + fail "empty list of ETags" + return xs diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index 5e48ee4..a47f2ac 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -12,7 +12,7 @@ module Network.HTTP.Lucu.Headers , toHeaders , fromHeaders - , headersP + , headers , printHeaders ) where @@ -116,11 +116,11 @@ fromHeaders (Headers m) = M.toList m field-value の先頭および末尾にある LWS は全て削除され、それ以外の LWS は單一の SP に變換される。 -} -headersP ∷ Parser Headers -{-# INLINEABLE headersP #-} -headersP = do xs ← P.many header - crlf - return $ toHeaders xs +headers ∷ Parser Headers +{-# INLINEABLE headers #-} +headers = do xs ← P.many header + crlf + return $ toHeaders xs where header ∷ Parser (CIAscii, Ascii) header = do name ← A.toCIAscii <$> token diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs index 2029a7f..36b6c49 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -6,11 +6,9 @@ module Network.HTTP.Lucu.HttpVersion ( HttpVersion(..) , printHttpVersion - - , httpVersionP + , httpVersion ) where -import qualified Blaze.Text.Int as BT import Control.Applicative import Control.Applicative.Unicode import Data.Ascii (AsciiBuilder) @@ -39,18 +37,15 @@ printHttpVersion v -- Optimisation for special cases. HttpVersion 1 0 → A.toAsciiBuilder "HTTP/1.0" HttpVersion 1 1 → A.toAsciiBuilder "HTTP/1.1" - -- General cases. + -- General (but almost never stumbling) cases. HttpVersion maj min - → A.toAsciiBuilder "HTTP/" ⊕ - A.unsafeFromBuilder (BT.integral maj) ⊕ - A.toAsciiBuilder "." ⊕ - A.unsafeFromBuilder (BT.integral min) + → A.toAsciiBuilder "HTTP/" ⊕ + A.toAsciiBuilder (A.unsafeFromString $ show maj) ⊕ + A.toAsciiBuilder "." ⊕ + A.toAsciiBuilder (A.unsafeFromString $ show min) -- |'Parser' for an 'HttpVersion'. -httpVersionP ∷ Parser HttpVersion -httpVersionP = string "HTTP/" - *> - choice [ string "1.1" *> pure (HttpVersion 1 1) - , string "1.0" *> pure (HttpVersion 1 0) - , HttpVersion <$> decimal ⊛ (char '.' *> decimal) - ] +httpVersion ∷ Parser HttpVersion +httpVersion = string "HTTP/" + *> + (HttpVersion <$> decimal ⊛ (char '.' *> decimal)) diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index e871159..3be8928 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -34,7 +34,6 @@ import Data.Ascii (Ascii) import qualified Data.ByteString as Strict import Data.Monoid.Unicode import Data.Sequence (Seq) -import qualified Data.Strict.Maybe as S import Data.Time import qualified Data.Time.HTTP as HTTP import Data.Typeable @@ -94,7 +93,7 @@ data SemanticallyInvalidInteraction = SEI { seiRequest ∷ !Request , seiExpectedContinue ∷ !Bool - , seiReqBodyLength ∷ !(S.Maybe RequestBodyLength) + , seiReqBodyLength ∷ !(Maybe RequestBodyLength) , seiResponse ∷ !Response , seiWillChunkBody ∷ !Bool @@ -138,7 +137,7 @@ data NormalInteraction , niRequest ∷ !Request , niResourcePath ∷ ![Strict.ByteString] , niExpectedContinue ∷ !Bool - , niReqBodyLength ∷ !(S.Maybe RequestBodyLength) + , niReqBodyLength ∷ !(Maybe RequestBodyLength) , niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest) , niReceivedBody ∷ !(TMVar Strict.ByteString) diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index 4b509bf..ab0e065 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -11,8 +11,8 @@ module Network.HTTP.Lucu.MIMEType , parseMIMEType , printMIMEType - , mimeTypeP - , mimeTypeListP + , mimeType + , mimeTypeList ) where import Control.Applicative @@ -52,7 +52,7 @@ printMIMEType (MIMEType maj min params) = A.toAsciiBuilder (A.fromCIAscii maj) ⊕ A.toAsciiBuilder "/" ⊕ A.toAsciiBuilder (A.fromCIAscii min) ⊕ - printParams params + printMIMEParams params -- |Parse 'MIMEType' from an 'Ascii'. This function throws an -- exception for parse error. @@ -65,20 +65,20 @@ parseMIMEType str where p ∷ Parser MIMEType {-# INLINE p #-} - p = do t ← mimeTypeP + p = do t ← mimeType endOfInput return t -- |'Parser' for an 'MIMEType'. -mimeTypeP ∷ Parser MIMEType -{-# INLINEABLE mimeTypeP #-} -mimeTypeP = do maj ← A.toCIAscii <$> token - _ ← char '/' - min ← A.toCIAscii <$> token - params ← paramsP - return $ MIMEType maj min params +mimeType ∷ Parser MIMEType +{-# INLINEABLE mimeType #-} +mimeType = do maj ← A.toCIAscii <$> token + _ ← char '/' + min ← A.toCIAscii <$> token + params ← mimeParams + return $ MIMEType maj min params -- |'Parser' for a list of 'MIMEType's. -mimeTypeListP ∷ Parser [MIMEType] -{-# INLINE mimeTypeListP #-} -mimeTypeListP = listOf mimeTypeP +mimeTypeList ∷ Parser [MIMEType] +{-# INLINE mimeTypeList #-} +mimeTypeList = listOf mimeType diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 86d7df6..d8bca8e 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -14,6 +14,7 @@ module Network.HTTP.Lucu.MIMEType.Guess ) where import Control.Applicative +import Control.Monad import qualified Data.Ascii as A import Data.Attoparsec.Char8 as P import qualified Data.Attoparsec.Lazy as LP @@ -60,7 +61,7 @@ parseExtMapFile fpath → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e) extMapP ∷ Parser [ (MIMEType, [Text]) ] -extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine) +extMapP = do xs ← P.many (try comment <|> try validLine <|> emptyLine) endOfInput return $ catMaybes xs where @@ -68,16 +69,14 @@ extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine) isSpc c = c ≡ '\x20' ∨ c ≡ '\x09' comment ∷ Parser (Maybe (MIMEType, [Text])) - comment = try $ - do skipWhile isSpc - _ ← char '#' + comment = do skipWhile isSpc + void $ char '#' skipWhile (≢ '\x0A') return Nothing validLine ∷ Parser (Maybe (MIMEType, [Text])) - validLine = try $ - do skipWhile isSpc - mime ← mimeTypeP + validLine = do skipWhile isSpc + mime ← mimeType skipWhile isSpc exts ← sepBy extP (skipWhile isSpc) return $ Just (mime, exts) @@ -86,9 +85,8 @@ extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine) extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A')) emptyLine ∷ Parser (Maybe (MIMEType, [Text])) - emptyLine = try $ - do skipWhile isSpc - _ ← char '\x0A' + emptyLine = do skipWhile isSpc + void $ char '\x0A' return Nothing compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v) diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index 72eef21..53174fa 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -1,52 +1,62 @@ {-# LANGUAGE DoAndIfThenElse + , FlexibleContexts , OverloadedStrings , RecordWildCards , ScopedTypeVariables , UnicodeSyntax #-} +-- |Parse \"multipart/form-data\" based on RFC 2388: +-- +-- +-- You usually don't have to use this module directly. module Network.HTTP.Lucu.MultipartForm ( FormData(..) - , multipartFormP + , parseMultipartFormData ) where import Control.Applicative hiding (many) -import Control.Monad +import Control.Applicative.Unicode hiding ((∅)) +import Control.Monad.Error +import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii) import qualified Data.Ascii as A import Data.Attoparsec -import qualified Data.ByteString.Char8 as BS +import qualified Data.Attoparsec.Lazy as LP import qualified Data.ByteString.Lazy.Char8 as LS +import Data.ByteString.Lazy.Search +import Data.Foldable +import Data.List import Data.Map (Map) import qualified Data.Map as M import Data.Maybe import Data.Monoid.Unicode +import Data.Sequence (Seq) +import Data.Sequence.Unicode hiding ((∅)) import Data.Text (Text) +import qualified Data.Text as T import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.Parser +import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.RFC2231 import Prelude.Unicode --- |This data type represents a form value and possibly an uploaded --- file name. +-- |'FormData' represents a form value and possibly an uploaded file +-- name. data FormData = FormData { - fdFileName ∷ Maybe Text - , fdContent ∷ LS.ByteString + fdFileName ∷ !(Maybe Text) + , fdMIMEType ∷ !MIMEType + , fdContent ∷ !(LS.ByteString) } data Part = Part { - ptHeaders ∷ Headers - , ptContDispo ∷ ContDispo - , ptBody ∷ LS.ByteString + ptContDispo ∷ !ContDispo + , ptContType ∷ !MIMEType + , ptBody ∷ !LS.ByteString } -instance HasHeaders Part where - getHeaders = ptHeaders - setHeaders pt hs = pt { ptHeaders = hs } - data ContDispo = ContDispo { dType ∷ !CIAscii @@ -58,93 +68,179 @@ printContDispo d = A.fromAsciiBuilder ( A.toAsciiBuilder (A.fromCIAscii $ dType d) ⊕ - printParams (dParams d) ) - -multipartFormP ∷ Ascii → Parser [(Text, FormData)] -multipartFormP boundary - = do void boundaryP - parts ← many $ partP boundaryP - void (string "--" "suffix") - crlf - catMaybes <$> mapM partToFormPair parts - - "multipartFormP" + printMIMEParams (dParams d) ) + +-- |Parse \"multipart/form-data\" and return either @'Left' err@ or +-- @'Right' result@. Note that there are currently the following +-- limitations: +-- +-- * Multiple files embedded as \"multipart/mixed\" within the +-- \"multipart/form-data\" aren't decomposed. +-- +-- * \"Content-Transfer-Encoding\"s are always ignored. +-- +-- * RFC 2388 says that non-ASCII field names are encoded according +-- to the method in RFC 2047 +-- , but they aren't +-- decoded. +parseMultipartFormData ∷ Ascii -- ^boundary + → LS.ByteString -- ^input + → Either String [(Ascii, FormData)] +parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go where - boundaryP ∷ Parser BS.ByteString - boundaryP = string ("--" ⊕ A.toByteString boundary) - - "boundaryP" - -partP ∷ Parser α → Parser Part -partP boundaryP - = do crlf - hs ← headersP - d ← getContDispo hs - body ← bodyP boundaryP - return $ Part hs d body + go ∷ (Functor m, MonadError String m) + ⇒ LS.ByteString + → m [Part] + {-# INLINEABLE go #-} + go src + = case LP.parse (prologue boundary) src of + LP.Done src' _ + → go' src' (∅) + LP.Fail _ eCtx e + → throwError $ "Unparsable multipart/form-data: " + ⧺ intercalate ", " eCtx + ⧺ ": " + ⧺ e + go' ∷ (Functor m, MonadError String m) + ⇒ LS.ByteString + → Seq Part + → m [Part] + {-# INLINEABLE go' #-} + go' src xs + = case LP.parse epilogue src of + LP.Done _ _ + → return $ toList xs + LP.Fail _ _ _ + → do (src', x) ← parsePart boundary src + go' src' $ xs ⊳ x + +prologue ∷ Ascii → Parser () +prologue boundary + = ( (string "--" "prefix") + *> + (string (A.toByteString boundary) "boundary") + *> + pure () + ) - "partP" + "prologue" + +epilogue ∷ Parser () +epilogue = ( (string "--" "suffix") + *> + crlf + *> + endOfInput + ) + + "epilogue" + +parsePart ∷ (Functor m, MonadError String m) + ⇒ Ascii + → LS.ByteString + → m (LS.ByteString, Part) +{-# INLINEABLE parsePart #-} +parsePart boundary src + = case LP.parse partHeader src of + LP.Done src' hdrs + → do dispo ← getContDispo hdrs + cType ← fromMaybe defaultCType <$> getContType hdrs + (body, src'') + ← getBody boundary src' + return (src'', Part dispo cType body) + LP.Fail _ eCtx e + → throwError $ "unparsable part: " + ⧺ intercalate ", " eCtx + ⧺ ": " + ⧺ e + where + defaultCType ∷ MIMEType + defaultCType = parseMIMEType "text/plain" + +partHeader ∷ Parser Headers +partHeader = crlf *> headers + +getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo +{-# INLINEABLE getContDispo #-} +getContDispo hdrs + = case getHeader "Content-Disposition" hdrs of + Nothing + → throwError "Content-Disposition is missing" + Just str + → case parseOnly p $ A.toByteString str of + Right d → return d + Left err → throwError $ "malformed Content-Disposition: " + ⧺ A.toString str + ⧺ ": " + ⧺ err + where + p = do dispo ← contentDisposition + endOfInput + return dispo -bodyP ∷ Parser α → Parser LS.ByteString -bodyP boundaryP - = manyOctetsTill anyWord8 (try $ crlf *> boundaryP) +contentDisposition ∷ Parser ContDispo +contentDisposition + = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams) - "bodyP" + "contentDisposition" + +getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType) +{-# INLINEABLE getContType #-} +getContType hdrs + = case getHeader "Content-Type" hdrs of + Nothing + → return Nothing + Just str + → case parseOnly p $ A.toByteString str of + Right d → return $ Just d + Left err → throwError $ "malformed Content-Type: " + ⧺ A.toString str + ⧺ ": " + ⧺ err + where + p = do t ← mimeType + endOfInput + return t + +getBody ∷ MonadError String m + ⇒ Ascii + → LS.ByteString + → m (LS.ByteString, LS.ByteString) +{-# INLINEABLE getBody #-} +getBody boundary src + = case breakFindAfter (A.toByteString boundary) src of + ((before, after), True) + → return (before, after) + _ → throwError "missing boundary" -partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData)) +partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData) {-# INLINEABLE partToFormPair #-} -partToFormPair pt - | dType (ptContDispo pt) ≡ "form-data" +partToFormPair pt@(Part {..}) + | dType ptContDispo ≡ "form-data" = do name ← partName pt - let fname = partFileName pt - let fd = FormData { - fdFileName = fname - , fdContent = ptBody pt - } - return $ Just (name, fd) + let fd = FormData { + fdFileName = partFileName pt + , fdMIMEType = ptContType + , fdContent = ptBody + } + return (name, fd) | otherwise - = return Nothing + = throwError $ "disposition type is not \"form-data\": " + ⧺ A.toString (A.fromCIAscii $ dType ptContDispo) -partName ∷ Monad m ⇒ Part → m Text +partName ∷ MonadError String m ⇒ Part → m Ascii {-# INLINEABLE partName #-} partName (Part {..}) = case M.lookup "name" $ dParams ptContDispo of Just name - → return name + → case A.fromText name of + Just a → return a + Nothing → throwError $ "Non-ascii part name: " + ⧺ T.unpack name Nothing - → fail ("form-data without name: " ⧺ - A.toString (printContDispo ptContDispo)) + → throwError $ "form-data without name: " + ⧺ A.toString (printContDispo ptContDispo) partFileName ∷ Part → Maybe Text -{-# INLINEABLE partFileName #-} partFileName (Part {..}) = M.lookup "filename" $ dParams ptContDispo - -getContDispo ∷ Monad m ⇒ Headers → m ContDispo -{-# INLINEABLE getContDispo #-} -getContDispo hdr - = case getHeader "Content-Disposition" hdr of - Nothing - → fail "There is a part without Content-Disposition in the multipart/form-data." - Just str - → let p = do d ← contDispoP - endOfInput - return d - bs = A.toByteString str - in - case parseOnly p bs of - Right d → return d - Left err → fail (concat [ "Unparsable Content-Disposition: " - , BS.unpack bs - , ": " - , err - ]) - -contDispoP ∷ Parser ContDispo -{-# INLINEABLE contDispoP #-} -contDispoP - = do dispoType ← A.toCIAscii <$> token - params ← paramsP - return $ ContDispo dispoType params - - "contDispoP" diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 6b935c8..8772264 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -7,21 +7,10 @@ -- use this module directly. module Network.HTTP.Lucu.Parser ( atMost - , manyOctetsTill ) where -import Blaze.ByteString.Builder (Builder, Write) -import qualified Blaze.ByteString.Builder as BB -import qualified Blaze.ByteString.Builder.Internal as BI import Control.Applicative -import Control.Applicative.Unicode hiding ((∅)) -import Control.Monad.Unicode -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LS -import Data.Monoid -import Data.Monoid.Unicode -import Data.Word -import Prelude.Unicode +import Control.Applicative.Unicode -- |@'atMost' n v@ is like @'P.many' v@ but accumulates @v@ at most -- @n@ times. @@ -31,67 +20,3 @@ atMost 0 _ = pure [] atMost n v = ( (:) <$> v ⊛ atMost (n-1) v ) <|> pure [] - -data OctetAccumState - = OctetAccumState { - casChunks ∷ !Builder - , casLastChunk ∷ !Write - } - -instance Monoid OctetAccumState where - {-# INLINE mempty #-} - mempty - = OctetAccumState { - casChunks = (∅) - , casLastChunk = (∅) - } - {-# INLINEABLE mappend #-} - mappend !a !b - = b { - casChunks = casChunks a ⊕ lastChunk a ⊕ casChunks b - } - -lastChunk ∷ OctetAccumState → Builder -{-# INLINEABLE lastChunk #-} -lastChunk !s = case toChunk s of - c → BB.insertByteString c - where - toChunk ∷ OctetAccumState → BS.ByteString - {-# INLINE toChunk #-} - toChunk = BB.toByteString ∘ BB.fromWrite ∘ casLastChunk - -snoc ∷ OctetAccumState → Word8 → OctetAccumState -{-# INLINEABLE snoc #-} -snoc !s !o - | BI.getBound (casLastChunk s) ≥ BI.defaultBufferSize - = s { - casChunks = casChunks s ⊕ lastChunk s - , casLastChunk = BB.writeWord8 o - } - | otherwise - = s { - casLastChunk = casLastChunk s ⊕ BB.writeWord8 o - } - -finish ∷ OctetAccumState → LS.ByteString -{-# INLINEABLE finish #-} -finish = BB.toLazyByteString ∘ toChunks - where - toChunks ∷ OctetAccumState → Builder - {-# INLINE toChunks #-} - toChunks !s = casChunks s ⊕ lastChunk s - --- |@'manyOctetsTill' p end@ takes as many octets untill @p@ succeeds. -manyOctetsTill ∷ ∀m b. (Monad m, Alternative m) - ⇒ m Word8 - → m b - → m LS.ByteString -{-# INLINEABLE manyOctetsTill #-} -manyOctetsTill p end = scan (∅) - where - scan ∷ OctetAccumState → m LS.ByteString - {-# INLINE scan #-} - scan !s - = (end *> pure (finish s)) - <|> - (scan =≪ (snoc s <$> p)) diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 8e3087e..26fbd53 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -17,7 +17,6 @@ import Data.Ascii (Ascii) import qualified Data.Ascii as A import qualified Data.ByteString.Char8 as C8 import Data.Maybe -import qualified Data.Strict.Maybe as S import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -37,7 +36,7 @@ data AugmentedRequest , arWillDiscardBody ∷ !Bool , arWillClose ∷ !Bool , arExpectedContinue ∷ !Bool - , arReqBodyLength ∷ !(S.Maybe RequestBodyLength) + , arReqBodyLength ∷ !(Maybe RequestBodyLength) } data RequestBodyLength @@ -57,7 +56,7 @@ preprocess localHost localPort req@(Request {..}) , arWillDiscardBody = False , arWillClose = False , arExpectedContinue = False - , arReqBodyLength = S.Nothing + , arReqBodyLength = Nothing } go ∷ State AugmentedRequest () go = do examineHttpVersion @@ -78,7 +77,7 @@ setWillClose ∷ Bool → State AugmentedRequest () setWillClose b = modify $ \ar → ar { arWillClose = b } -setBodyLength ∷ S.Maybe RequestBodyLength → State AugmentedRequest () +setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest () setBodyLength len = modify $ \ar → ar { arReqBodyLength = len } @@ -174,7 +173,7 @@ examineHeaders | v ≡ "identity" → return () | v ≡ "chunked" - → setBodyLength $ S.Just Chunked + → setBodyLength $ Just Chunked | otherwise → setStatus NotImplemented @@ -183,7 +182,7 @@ examineHeaders Just value → case C8.readInt value of Just (len, garbage) | C8.null garbage ∧ len ≥ 0 - → setBodyLength $ S.Just $ Fixed len + → setBodyLength $ Just $ Fixed len _ → setStatus BadRequest case getCIHeader "Connection" req of @@ -198,9 +197,9 @@ examineBodyLength len ← gets arReqBodyLength if reqMustHaveBody req then -- POST and PUT requests must have an entity body. - when (S.isNothing len) + when (isNothing len) $ setStatus LengthRequired else -- Other requests must NOT have an entity body. - when (S.isJust len) + when (isJust len) $ setStatus BadRequest diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs index 791c891..1046c5d 100644 --- a/Network/HTTP/Lucu/RFC2231.hs +++ b/Network/HTTP/Lucu/RFC2231.hs @@ -2,7 +2,6 @@ DoAndIfThenElse , OverloadedStrings , RecordWildCards - , ScopedTypeVariables , UnicodeSyntax #-} -- |Provide functionalities to encode/decode MIME parameter values in @@ -11,12 +10,11 @@ -- -- You usually don't have to use this module directly. module Network.HTTP.Lucu.RFC2231 - ( printParams - , paramsP + ( printMIMEParams + , mimeParams ) where import Control.Applicative -import qualified Control.Exception as E import Control.Monad hiding (mapM) import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii, AsciiBuilder) @@ -34,21 +32,19 @@ import qualified Data.Sequence as S import Data.Sequence.Unicode hiding ((∅)) import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.ICU.Convert as TC import Data.Text.Encoding -import Data.Text.ICU.Error +import Data.Text.Encoding.Error import Data.Traversable import Data.Word import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils import Prelude hiding (concat, mapM, takeWhile) import Prelude.Unicode -import System.IO.Unsafe --- |Convert parameter values to an 'AsciiBuilder'. -printParams ∷ Map CIAscii Text → AsciiBuilder -{-# INLINEABLE printParams #-} -printParams m = M.foldlWithKey f (∅) m +-- |Convert MIME parameter values to an 'AsciiBuilder'. +printMIMEParams ∷ Map CIAscii Text → AsciiBuilder +{-# INLINEABLE printMIMEParams #-} +printMIMEParams m = M.foldlWithKey f (∅) m -- THINKME: Use foldlWithKey' for newer Data.Map where f ∷ AsciiBuilder → CIAscii → Text → AsciiBuilder @@ -127,10 +123,10 @@ section ∷ ExtendedParam → Integer section (InitialEncodedParam {..}) = 0 section ep = epSection ep --- |'Parser' for parameter values. -paramsP ∷ Parser (Map CIAscii Text) -{-# INLINEABLE paramsP #-} -paramsP = decodeParams =≪ P.many (try paramP) +-- |'Parser' for MIME parameter values. +mimeParams ∷ Parser (Map CIAscii Text) +{-# INLINEABLE mimeParams #-} +mimeParams = decodeParams =≪ P.many (try paramP) paramP ∷ Parser ExtendedParam paramP = do skipMany lws @@ -168,6 +164,7 @@ initialEncodedValue -- 2231 doesn't tell us what we should do when the -- charset is omitted. return ("US-ASCII", payload) + -- FIXME: Rethink about this behaviour. else return (charset, payload) where @@ -209,12 +206,13 @@ decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text) {-# INLINE decodeParams #-} decodeParams = (mapM decodeSections =≪) ∘ sortBySection -sortBySection ∷ ∀m. Monad m +sortBySection ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii (Map Integer ExtendedParam)) sortBySection = flip go (∅) where - go ∷ [ExtendedParam] + go ∷ Monad m + ⇒ [ExtendedParam] → Map CIAscii (Map Integer ExtendedParam) → m (Map CIAscii (Map Integer ExtendedParam)) go [] m = return m @@ -240,10 +238,11 @@ sortBySection = flip go (∅) , "'" ]) -decodeSections ∷ ∀m. Monad m ⇒ Map Integer ExtendedParam → m Text +decodeSections ∷ Monad m ⇒ Map Integer ExtendedParam → m Text decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) where - toSeq ∷ Map Integer ExtendedParam + toSeq ∷ Monad m + ⇒ Map Integer ExtendedParam → Integer → Seq ExtendedParam → m (Seq ExtendedParam) @@ -262,15 +261,15 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) , "'" ]) - decodeSeq ∷ Seq ExtendedParam → m Text + decodeSeq ∷ Monad m ⇒ Seq ExtendedParam → m Text decodeSeq sects = case S.viewl sects of EmptyL → fail "decodeSeq: internal error: empty seq" InitialEncodedParam {..} :< xs - → do conv ← openConv epCharset - let t = TC.toUnicode conv epPayload - decodeSeq' (Just conv) xs $ S.singleton t + → do d ← getDecoder epCharset + t ← decodeStr d epPayload + decodeSeq' (Just d) xs $ S.singleton t ContinuedEncodedParam {..} :< _ → fail "decodeSeq: internal error: CEP at section 0" AsciiParam {..} :< xs @@ -278,22 +277,22 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) in decodeSeq' Nothing xs $ S.singleton t - decodeSeq' ∷ Maybe (TC.Converter) + decodeSeq' ∷ Monad m + ⇒ Maybe Decoder → Seq ExtendedParam → Seq Text → m Text - decodeSeq' convM sects chunks + decodeSeq' decoder sects chunks = case S.viewl sects of EmptyL → return $ T.concat $ toList chunks InitialEncodedParam {..} :< _ → fail "decodeSeq': internal error: IEP at section > 0" ContinuedEncodedParam {..} :< xs - → case convM of - Just conv - → let t = TC.toUnicode conv epPayload - in - decodeSeq' convM xs $ chunks ⊳ t + → case decoder of + Just d + → do t ← decodeStr d epPayload + decodeSeq' decoder xs $ chunks ⊳ t Nothing → fail (concat [ "Section " , show epSection @@ -304,13 +303,19 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) AsciiParam {..} :< xs → let t = A.toText apPayload in - decodeSeq' convM xs $ chunks ⊳ t + decodeSeq' decoder xs $ chunks ⊳ t + +type Decoder = BS.ByteString → Either UnicodeException Text + +decodeStr ∷ Monad m ⇒ Decoder → BS.ByteString → m Text +decodeStr decoder str + = case decoder str of + Right t → return t + Left e → fail $ show e - openConv ∷ CIAscii → m TC.Converter - openConv charset - = let cs = A.toString $ A.fromCIAscii charset - open' = TC.open cs (Just True) - in - case unsafePerformIO $ E.try open' of - Right conv → return conv - Left err → fail $ show (err ∷ ICUError) +getDecoder ∷ Monad m ⇒ CIAscii → m Decoder +getDecoder charset + | charset ≡ "UTF-8" = return decodeUtf8' + | charset ≡ "US-ASCII" = return decodeUtf8' + | otherwise = fail $ "No decoders found for charset: " + ⧺ A.toString (A.fromCIAscii charset) diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs index 853907a..58286db 100644 --- a/Network/HTTP/Lucu/Request.hs +++ b/Network/HTTP/Lucu/Request.hs @@ -10,7 +10,7 @@ module Network.HTTP.Lucu.Request ( Method(..) , Request(..) , reqMustHaveBody - , requestP + , request ) where import Control.Applicative @@ -62,42 +62,42 @@ reqMustHaveBody (reqMethod → m) | otherwise = False -- |'Parser' for a 'Request'. -requestP ∷ Parser Request -requestP = do skipMany crlf - (method, uri, version) ← requestLineP - headers ← headersP - return Request { - reqMethod = method - , reqURI = uri - , reqVersion = version - , reqHeaders = headers - } +request ∷ Parser Request +request = do skipMany crlf + (meth, u, ver) ← requestLine + hdrs ← headers + return Request { + reqMethod = meth + , reqURI = u + , reqVersion = ver + , reqHeaders = hdrs + } -requestLineP ∷ Parser (Method, URI, HttpVersion) -requestLineP = do method ← methodP - sp - uri ← uriP - sp - ver ← httpVersionP - crlf - return (method, uri, ver) +requestLine ∷ Parser (Method, URI, HttpVersion) +requestLine = do meth ← method + sp + u ← uri + sp + ver ← httpVersion + crlf + return (meth, u, ver) -methodP ∷ Parser Method -methodP = choice - [ string "OPTIONS" ≫ return OPTIONS - , string "GET" ≫ return GET - , string "HEAD" ≫ return HEAD - , string "POST" ≫ return POST - , string "PUT" ≫ return PUT - , string "DELETE" ≫ return DELETE - , string "TRACE" ≫ return TRACE - , string "CONNECT" ≫ return CONNECT - , ExtensionMethod <$> token - ] +method ∷ Parser Method +method = choice + [ string "OPTIONS" ≫ return OPTIONS + , string "GET" ≫ return GET + , string "HEAD" ≫ return HEAD + , string "POST" ≫ return POST + , string "PUT" ≫ return PUT + , string "DELETE" ≫ return DELETE + , string "TRACE" ≫ return TRACE + , string "CONNECT" ≫ return CONNECT + , ExtensionMethod <$> token + ] -uriP ∷ Parser URI -uriP = do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20')) - let str = C8.unpack bs - case parseURIReference str of - Nothing -> fail ("Unparsable URI: " ⧺ str) - Just uri -> return uri +uri ∷ Parser URI +uri = do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20')) + let str = C8.unpack bs + case parseURIReference str of + Nothing → fail ("Unparsable URI: " ⧺ str) + Just u → return u diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 5a4559e..7f48c9b 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -17,7 +17,7 @@ import qualified Data.Attoparsec.Lazy as LP import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy import Data.List -import qualified Data.Strict.Maybe as S +import Data.Maybe import Data.Monoid.Unicode import qualified Data.Sequence as S import Data.Sequence.Unicode hiding ((∅)) @@ -96,7 +96,7 @@ acceptRequest ctx@(Context {..}) input -- リクエストを讀む。パースできない場合は直ちに 400 Bad -- Request 應答を設定し、それを出力してから切斷するやうに -- ResponseWriter に通知する。 - case LP.parse requestP input of + case LP.parse request input of LP.Done input' req → acceptParsableRequest ctx req input' LP.Fail _ _ _ → acceptNonparsableRequest ctx @@ -157,7 +157,7 @@ waitForReceiveBodyReq ∷ HandleLike h → Lazy.ByteString → IO () waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input - = case S.fromJust niReqBodyLength of + = case fromJust niReqBodyLength of Chunked → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input Fixed len @@ -207,13 +207,13 @@ wasteAllChunks ctx rsrcTid = go where go ∷ Lazy.ByteString → ChunkReceivingState → IO () go input Initial - = case LP.parse chunkHeaderP input of + = case LP.parse chunkHeader input of LP.Done input' chunkLen | chunkLen ≡ 0 → gotFinalChunk input' | otherwise → gotChunk input' chunkLen LP.Fail _ eCtx e → chunkWasMalformed rsrcTid eCtx e - "wasteAllChunks: chunkHeaderP" + "wasteAllChunks: chunkHeader" go input (InChunk chunkLen) = gotChunk input chunkLen @@ -221,21 +221,21 @@ wasteAllChunks ctx rsrcTid = go gotChunk input chunkLen = let input' = Lazy.drop (fromIntegral chunkLen) input in - case LP.parse chunkFooterP input' of + case LP.parse chunkFooter input' of LP.Done input'' _ → go input'' Initial LP.Fail _ eCtx e → chunkWasMalformed rsrcTid eCtx e - "wasteAllChunks: chunkFooterP" + "wasteAllChunks: chunkFooter" gotFinalChunk ∷ Lazy.ByteString → IO () gotFinalChunk input - = case LP.parse chunkTrailerP input of + = case LP.parse chunkTrailer input of LP.Done input' _ → acceptRequest ctx input' LP.Fail _ eCtx e → chunkWasMalformed rsrcTid eCtx e - "wasteAllChunks: chunkTrailerP" + "wasteAllChunks: chunkTrailer" readCurrentChunk ∷ HandleLike h ⇒ Context h @@ -249,7 +249,7 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go where go ∷ Lazy.ByteString → ChunkReceivingState → IO () go input Initial - = case LP.parse chunkHeaderP input of + = case LP.parse chunkHeader input of LP.Done input' chunkLen | chunkLen ≡ 0 → gotFinalChunk input' @@ -257,7 +257,7 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go → gotChunk input' chunkLen LP.Fail _ eCtx e → chunkWasMalformed rsrcTid eCtx e - "readCurrentChunk: chunkHeaderP" + "readCurrentChunk: chunkHeader" go input (InChunk chunkLen) = gotChunk input chunkLen @@ -270,24 +270,24 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go chunkLen' = chunkLen - actualReadBytes atomically $ putTMVar niReceivedBody block' if chunkLen' ≡ 0 then - case LP.parse chunkFooterP input' of + case LP.parse chunkFooter input' of LP.Done input'' _ → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial LP.Fail _ eCtx e → chunkWasMalformed rsrcTid eCtx e - "readCurrentChunk: chunkFooterP: " + "readCurrentChunk: chunkFooter" else waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen' gotFinalChunk ∷ Lazy.ByteString → IO () gotFinalChunk input = do atomically $ putTMVar niReceivedBody (∅) - case LP.parse chunkTrailerP input of + case LP.parse chunkTrailer input of LP.Done input' _ → acceptRequest ctx input' LP.Fail _ eCtx e → chunkWasMalformed rsrcTid eCtx e - "readCurrentChunk: chunkTrailerP" + "readCurrentChunk: chunkTrailer" chunkWasMalformed ∷ ThreadId → [String] → String → String → IO () chunkWasMalformed tid eCtx e msg diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 71ff483..6463bc8 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -141,13 +141,13 @@ import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder as BB import qualified Blaze.ByteString.Builder.Internal as BB import Control.Applicative +import Control.Arrow import Control.Monad import Control.Monad.IO.Class 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 as Strict import qualified Data.ByteString.Lazy as Lazy @@ -158,7 +158,6 @@ import Data.Monoid import Data.Monoid.Unicode import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Encoding as T import Data.Time import qualified Data.Time.HTTP as HTTP import Network.HTTP.Lucu.Abortion @@ -182,15 +181,17 @@ import Prelude.Unicode -- |Get the string representation of the address of remote host. If -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'. getRemoteAddr' ∷ Resource HostName -getRemoteAddr' - = do sa ← getRemoteAddr - (fromJust ∘ fst) <$> (liftIO $ getNameInfo [NI_NUMERICHOST] True False sa) +getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr + where + toNM ∷ SockAddr → IO HostName + toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False -- |Resolve an address to the remote host. getRemoteHost ∷ Resource (Maybe HostName) -getRemoteHost - = do sa ← getRemoteAddr - fst <$> (liftIO $ getNameInfo [] True False sa) +getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr + where + getHN ∷ SockAddr → IO (Maybe HostName) + getHN = (fst <$>) ∘ getNameInfo [] True False -- |Get the 'Method' value of the request. getMethod ∷ Resource Method @@ -218,9 +219,8 @@ getPathInfo = do rsrcPath ← getResourcePath -- |Assume the query part of request URI as -- application\/x-www-form-urlencoded, and parse it into pairs of -- @(name, formData)@. This function doesn't read the request --- body. Field names are decoded in UTF-8 for an hardly avoidable --- reason. See 'getForm'. -getQueryForm ∷ Resource [(Text, FormData)] +-- body. +getQueryForm ∷ Resource [(Strict.ByteString, FormData)] getQueryForm = parse' <$> getRequestURI where parse' = map toPairWithFormData ∘ @@ -230,13 +230,14 @@ getQueryForm = parse' <$> getRequestURI drop 1 ∘ uriQuery -toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData) +toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData) toPairWithFormData (name, value) = let fd = FormData { fdFileName = Nothing + , fdMIMEType = parseMIMEType "text/plain" , fdContent = Lazy.fromChunks [value] } - in (T.decodeUtf8 name, fd) + in (name, fd) -- |@'getHeader' name@ returns the value of the request header field -- @name@. Comparison of header name is case-insensitive. Note that @@ -260,7 +261,7 @@ getAccept Left _ → abort $ mkAbortion' BadRequest $ "Unparsable Accept: " ⊕ A.toText accept where - p = do xs ← mimeTypeListP + p = do xs ← mimeTypeList P.endOfInput return xs @@ -292,7 +293,7 @@ getAcceptEncoding Left _ → abort $ mkAbortion' BadRequest $ "Unparsable Accept-Encoding: " ⊕ A.toText ae where - p = do xs ← acceptEncodingListP + p = do xs ← acceptEncodingList P.endOfInput return xs @@ -320,7 +321,7 @@ getContentType Left _ → abort $ mkAbortion' BadRequest $ "Unparsable Content-Type: " ⊕ A.toText cType where - p = do t ← mimeTypeP + p = do t ← mimeType P.endOfInput return t @@ -337,7 +338,7 @@ getAuthorization Right ac → return $ Just ac Left _ → return Nothing where - p = do ac ← authCredentialP + p = do ac ← authCredential P.endOfInput return ac @@ -436,7 +437,7 @@ foundETag tag driftTo ReceivingBody where - p = do xs ← eTagListP + p = do xs ← eTagList P.endOfInput return xs @@ -527,7 +528,6 @@ foundNoEntity' ∷ Resource () {-# INLINE foundNoEntity' #-} foundNoEntity' = foundNoEntity Nothing - -- |@'getChunks' limit@ attemts to read the entire request body up to -- @limit@ bytes, and then make the 'Resource' transit to the -- /Deciding Header/ state. When the actual size of the body is larger @@ -577,13 +577,9 @@ getChunks' limit = go limit (∅) -- Media Type\". If the request has no \"Content-Type\", it aborts -- with \"400 Bad Request\". -- --- Field names in @multipart\/form-data@ will be precisely decoded in --- accordance with RFC 2231. On the other hand, --- @application\/x-www-form-urlencoded@ says nothing about character --- encodings for field names, so they'll always be decoded in --- UTF-8. (This could be a bad design, but I can't think of any better --- idea.) -getForm ∷ Maybe Int → Resource [(Text, FormData)] +-- Note that there are currently a few limitations on parsing +-- @multipart/form-data@. See 'parseMultipartFormData' +getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)] getForm limit = do cTypeM ← getContentType case cTypeM of @@ -620,19 +616,9 @@ getForm limit Just b → return b Nothing → abort $ mkAbortion' BadRequest $ "Malformed boundary: " ⊕ boundary - case LP.parse (p b) src of - LP.Done _ formList - → return formList - LP.Fail _ eCtx e - → abort $ mkAbortion' BadRequest - $ "Unparsable multipart/form-data: " - ⊕ T.pack (intercalate ", " eCtx) - ⊕ ": " - ⊕ T.pack e - where - p b = do xs ← multipartFormP b - P.endOfInput - return xs + case parseMultipartFormData b src of + Right xs → return $ map (first A.toByteString) xs + Left err → abort $ mkAbortion' BadRequest $ T.pack err -- |@'redirect' code uri@ declares the response status as @code@ and -- \"Location\" header field as @uri@. The @code@ must satisfy diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index 9df36a6..0a1f89f 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -329,9 +329,7 @@ setStatus sc -- body and thinks that the residual 10 bytes is a part of the header -- of the next response. setHeader ∷ CIAscii → Ascii → Resource () -setHeader name value - = do ni ← getInteraction - liftIO $ atomically $ go ni +setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction where go ∷ NormalInteraction → STM () go (NI {..}) @@ -346,9 +344,7 @@ setHeader name value -- |@'deleteHeader' name@ deletes a response header @name@ if -- any. This function is not intended to be used so frequently. deleteHeader ∷ CIAscii → Resource () -deleteHeader name - = do ni ← getInteraction - liftIO $ atomically $ go ni +deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction where go ∷ NormalInteraction → STM () go (NI {..}) @@ -368,9 +364,7 @@ deleteHeader name -- \"Content-Type\" before applying this function. See -- 'setContentType'. putBuilder ∷ Builder → Resource () -putBuilder b - = do ni ← getInteraction - liftIO $ atomically $ go ni +putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction where go ∷ NormalInteraction → STM () go ni@(NI {..}) @@ -383,9 +377,7 @@ putBuilder b putTMVar niBodyToSend b driftTo ∷ InteractionState → Resource () -driftTo newState - = do ni ← getInteraction - liftIO $ atomically $ driftTo' ni newState +driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo' driftTo' ∷ NormalInteraction → InteractionState → STM () driftTo' ni@(NI {..}) newState diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index 5c25b54..35c168f 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -23,8 +23,6 @@ module Network.HTTP.Lucu.Response , isError , isClientError , isServerError - - , statusCode ) where import Data.Ascii (Ascii, AsciiBuilder) @@ -176,8 +174,6 @@ satisfy ∷ (Int → Bool) → StatusCode → Bool {-# INLINE satisfy #-} satisfy p (statusCode → (# num, _ #)) = p num --- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual --- representation of @sc@. statusCode ∷ StatusCode → (# Int, Ascii #) {-# INLINEABLE statusCode #-} @@ -231,3 +227,5 @@ statusCode ServiceUnavailable = (# 503, "Service Unavailable" statusCode GatewayTimeout = (# 504, "Gateway Timeout" #) statusCode HttpVersionNotSupported = (# 505, "HTTP Version Not Supported" #) statusCode InsufficientStorage = (# 507, "Insufficient Storage" #) +-- FIXME: Textual representations should also include numbers. +-- FIXME: StatusCode should be a type class rather than a type. diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 7dbb116..3d38b8b 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -96,3 +96,5 @@ show3 = A.unsafeFromBuilder ∘ go | 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) +-- FIXME: Drop this function as soon as possible, to eliminate the +-- dependency on blaze-textual. diff --git a/bugs/issue-a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml b/bugs/issue-a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml index e4a9614..43cf56d 100644 --- a/bugs/issue-a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml +++ b/bugs/issue-a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml @@ -1,5 +1,5 @@ --- !ditz.rubyforge.org,2008-03-06/issue -title: "Add a configuration flag -fSSL to enable SSL support (default: on)" +title: "Add a configuration flag -fSSL to enable SSL support (default: off)" desc: |- Reason #1: SSL support isn't essential for Lucu. Reason #2: We have toooo many dependencies now, want to drop at least HsOpenSSL. @@ -18,4 +18,8 @@ log_events: - PHO - created - "" +- - 2011-10-27 17:33:31.904875 Z + - PHO + - edited title + - Should be defaulted to off! git_branch: diff --git a/data/CompileMimeTypes.hs b/data/CompileMimeTypes.hs index 8118406..9ba5b1e 100755 --- a/data/CompileMimeTypes.hs +++ b/data/CompileMimeTypes.hs @@ -1,10 +1,13 @@ #!/usr/bin/env runghc - +{-# LANGUAGE + UnicodeSyntax + #-} import Network.HTTP.Lucu.MIMEType.Guess import System -main = do [inFile, outFile] <- getArgs - extMap <- parseExtMapFile inFile +main ∷ IO () +main = do [inFile, outFile] ← getArgs + extMap ← parseExtMapFile inFile let src = serializeExtMap extMap