From ece223c516e66223ef1d5d8e6bbe4054a235d983 Mon Sep 17 00:00:00 2001 From: PHO Date: Thu, 27 Oct 2011 02:21:09 +0900 Subject: [PATCH] Many bugfixes Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- ImplantFile.hs | 165 ++++++------------------- Lucu.cabal | 1 + Network/HTTP/Lucu/Chunk.hs | 11 +- Network/HTTP/Lucu/Config.hs | 5 +- Network/HTTP/Lucu/Headers.hs | 14 ++- Network/HTTP/Lucu/Interaction.hs | 1 + Network/HTTP/Lucu/MIMEType/Guess.hs | 1 + Network/HTTP/Lucu/MultipartForm.hs | 55 +++++---- Network/HTTP/Lucu/Parser.hs | 97 +++++++++++++++ Network/HTTP/Lucu/Parser/Http.hs | 153 +++++++---------------- Network/HTTP/Lucu/RFC2231.hs | 76 +++++++----- Network/HTTP/Lucu/RequestReader.hs | 49 ++++---- Network/HTTP/Lucu/Resource.hs | 59 +++++---- Network/HTTP/Lucu/Resource/Internal.hs | 14 +-- Network/HTTP/Lucu/StaticFile.hs | 3 +- Network/HTTP/Lucu/Utils.hs | 19 +-- examples/Multipart.hs | 26 ++-- 17 files changed, 362 insertions(+), 387 deletions(-) create mode 100644 Network/HTTP/Lucu/Parser.hs diff --git a/ImplantFile.hs b/ImplantFile.hs index 67633f7..c3cff03 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -41,27 +41,27 @@ data CmdOpt deriving (Eq, Show) options ∷ [OptDescr CmdOpt] -options = [ Option ['o'] ["output"] +options = [ Option "o" ["output"] (ReqArg OptOutput "FILE") "Output to the FILE." - , Option ['m'] ["module"] + , Option "m" ["module"] (ReqArg OptModName "MODULE") "Specify the resulting module name. (required)" - , Option ['s'] ["symbol"] + , Option "s" ["symbol"] (ReqArg OptSymName "SYMBOL") "Specify the resulting symbol name." - , Option ['t'] ["mime-type"] + , Option "t" ["mime-type"] (ReqArg OptMIMEType "TYPE") "Specify the MIME Type of the file." - , Option ['e'] ["etag"] + , Option "e" ["etag"] (ReqArg OptETag "TAG") "Specify the ETag of the file." - , Option ['h'] ["help"] + , Option "h" ["help"] (NoArg OptHelp) "Print this message." ] @@ -126,19 +126,15 @@ generateHaskellSource opts srcFile let hsModule = mkModule modName symName imports decls imports = mkImports useGZip - decls = concat ([ resourceDecl symName useGZip - , entityTagDecl eTag - , lastModifiedDecl lastMod - , contentTypeDecl mimeType - ] - ⧺ - if useGZip then - [ gunzipAndPutChunkDecl - , dataDecl (name "gzippedData") gzippedB64 - ] - else - [ dataDecl (name "rawData") rawB64 ] - ) + decls = concat [ resourceDecl symName useGZip + , entityTagDecl eTag + , lastModifiedDecl lastMod + , contentTypeDecl mimeType + , if useGZip then + dataDecl (name "gzippedData") gzippedB64 + else + dataDecl (name "rawData") rawB64 + ] hPutStrLn output header hPutStrLn output (prettyPrint hsModule) @@ -163,16 +159,9 @@ mkImports useGZip False False Nothing Nothing Nothing ] ⧺ - if useGZip then - [ ImportDecl (⊥) (ModuleName "Blaze.ByteString.Builder.ByteString") - True False Nothing (Just (ModuleName "BB")) Nothing - , ImportDecl (⊥) (ModuleName "Codec.Compression.Zlib.Internal") - False False Nothing Nothing Nothing - , ImportDecl (⊥) (ModuleName "Data.Text") - True False Nothing (Just (ModuleName "T")) Nothing - ] - else - [] + [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip") + False False Nothing Nothing Nothing + | useGZip ] resourceDecl ∷ Name → Bool → [Decl] resourceDecl symName useGZip @@ -223,16 +212,18 @@ resGetGZipped = qualStmt $ If (var condVarName) (doE [ setContentEncodingGZipStmt - , outputStmt (var dataVarName) + , putChunksStmt (var dataVarName) ]) - (function "gunzipAndPutChunk" `app` var dataVarName) + (putChunksExp + (paren + (function "decompress" `app` var dataVarName))) resGetRaw ∷ Exp resGetRaw = function "Just" `app` paren (doE [ foundEntityStmt , setContentTypeStmt - , outputStmt (function "rawData") + , putChunksStmt (function "rawData") ]) setContentEncodingGZipStmt ∷ Stmt @@ -259,9 +250,11 @@ setContentTypeStmt function "contentType" ) -outputStmt ∷ Exp → Stmt -outputStmt e - = qualStmt $ function "putChunk" `app` e +putChunksExp ∷ Exp → Exp +putChunksExp = app (function "putChunks") + +putChunksStmt ∷ Exp → Stmt +putChunksStmt = qualStmt ∘ putChunksExp entityTagDecl ∷ ETag → [Decl] entityTagDecl eTag @@ -279,6 +272,7 @@ lastModifiedDecl ∷ UTCTime → [Decl] lastModifiedDecl lastMod = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime"))) , nameBind (⊥) varName valExp + , InlineSig (⊥) False AlwaysActive (UnQual varName) ] where varName ∷ Name @@ -291,6 +285,7 @@ contentTypeDecl ∷ MIMEType → [Decl] contentTypeDecl mime = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType"))) , nameBind (⊥) varName valExp + , InlineSig (⊥) False AlwaysActive (UnQual varName) ] where varName ∷ Name @@ -302,88 +297,11 @@ contentTypeDecl mime mimeToString ∷ MIMEType → String mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType -gunzipAndPutChunkDecl ∷ [Decl] -gunzipAndPutChunkDecl - = [ TypeSig (⊥) [funName] - (TyFun (TyCon (Qual (ModuleName "Lazy") (name "ByteString"))) - tyResourceUnit) - , sfun (⊥) funName [] (UnGuardedRhs funExp) (binds goDecl) - ] - where - funName ∷ Name - funName = name "gunzipAndPutChunk" - - goName ∷ Name - goName = name "go" - - tyResourceUnit ∷ Type - tyResourceUnit - = TyApp (TyCon (UnQual (name "Resource"))) - (TyTuple Boxed []) - - funExp ∷ Exp - funExp = var goName - `app` - function "." - `app` - metaFunction "decompressWithErrors" - [ function "gzipFormat" - , function "defaultDecompressParams" - ] - - goDecl ∷ [Decl] - goDecl = [ TypeSig (⊥) [goName] - (TyFun (TyCon (UnQual (name "DecompressStream"))) - tyResourceUnit) - , FunBind [ Match (⊥) goName [pvar (name "StreamEnd")] - Nothing (UnGuardedRhs endExp) (binds []) - , Match (⊥) goName [pApp (name "StreamChunk") - [ pvar (name "x") - , pvar (name "xs") ]] - Nothing (UnGuardedRhs chunkExp) (binds []) - , Match (⊥) goName [pApp (name "StreamError") - [ wildcard - , pvar (name "msg") ]] - Nothing (UnGuardedRhs errorExp) (binds []) - ] - ] - - endExp ∷ Exp - endExp = function "return" `app` tuple [] - - chunkExp ∷ Exp - chunkExp = function "putBuilder" - `app` - paren ( qvar (ModuleName "BB") (name "fromByteString") - `app` - var (name "x") - ) - `app` - function ">>" - `app` - function "go" `app` var (name "xs") - - errorExp ∷ Exp - errorExp = metaFunction "abort" - [ var (name "InternalServerError") - , listE [] - , function "Just" - `app` - paren ( qvar (ModuleName "T") (name "pack") - `app` - paren ( strE "gunzip: " - `app` - function "++" - `app` - var (name "msg") - ) - ) - ] - dataDecl ∷ Name → [Strict.ByteString] → [Decl] dataDecl varName chunks = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString"))) , nameBind (⊥) varName valExp + , InlineSig (⊥) False AlwaysActive (UnQual varName) ] where valExp ∷ Exp @@ -570,12 +488,15 @@ openOutput opts entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e" lastModified ∷ UTCTime + {-# NOINLINE lastModified #-} lastModified = read "2007-11-05 04:47:56.008366 UTC" contentType ∷ MIMEType + {-# NOINLINE contentType #-} contentType = parseMIMEType "image/png" rawData ∷ Lazy.ByteString + {-# NOINLINE rawData #-} rawData = Lazy.fromChunks [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..." , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..." @@ -585,9 +506,7 @@ openOutput opts 壓縮される場合は次のやうに變はる: ------------------------------------------------------------------------------ -- import に追加 - import qualified Blaze.ByteString.Builder.ByteString as BB - import Codec.Compression.Zlib.Internal - import qualified Data.Text as T + import Codec.Compression.Zlib -- ResourceDef は次のやうに變化 baz ∷ ResourceDef @@ -601,9 +520,9 @@ openOutput opts gzipAllowed ← isEncodingAcceptable "gzip" if gzipAllowed then do setContentEncoding ["gzip"] - putChunk gzippedData + putChunks gzippedData else - gunzipAndPutChunk gzippedData + putChunks (decompress gzippedData) , resHead = Just $ do foundEntity entityTag lastModified setContentType contentType @@ -612,17 +531,9 @@ openOutput opts , resDelete = Nothing } - -- 追加 - gunzipAndPutChunk :: Lazy.ByteString -> Resource () - gunzipAndPutChunk = go . decompressWithErrors gzipFormat defaultDecompressParams - where - go :: DecompressStream -> Resource () - go StreamEnd = return () - go (StreamChunk x xs) = putBuilder (BB.fromByteString x) >> go xs - go (StreamError _ msg) = abort InternalServerError [] (Just (T.pack ("gunzip: " ++ msg))) - -- rawData の代はりに gzippedData gzippedData ∷ Lazy.ByteString + {-# NOINLINE gzippedData #-} gzippedData = Lazy.fromChunks [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..." , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..." diff --git a/Lucu.cabal b/Lucu.cabal index cd69066..a104edf 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -84,6 +84,7 @@ Library Network.HTTP.Lucu.MIMEType.DefaultExtensionMap Network.HTTP.Lucu.MIMEType.Guess Network.HTTP.Lucu.Parser.Http + Network.HTTP.Lucu.Parser Network.HTTP.Lucu.RFC2231 Network.HTTP.Lucu.Request Network.HTTP.Lucu.Resource diff --git a/Network/HTTP/Lucu/Chunk.hs b/Network/HTTP/Lucu/Chunk.hs index 25d6907..b48727c 100644 --- a/Network/HTTP/Lucu/Chunk.hs +++ b/Network/HTTP/Lucu/Chunk.hs @@ -21,12 +21,11 @@ chunkHeaderP = do len ← hexadecimal return len where extension ∷ Parser () - extension = skipMany $ - do _ ← char ';' - _ ← token - _ ← char '=' - _ ← token <|> quotedStr - return () + extension + = skipMany ( char ';' *> + token *> + char '=' *> + (token <|> quotedStr) ) chunkFooterP ∷ Parser () chunkFooterP = crlf diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index 68bc365..2ea2055 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -59,9 +59,8 @@ data Config = Config { -- |The maximum length of request entity to accept in octets. Note -- that this is nothing but a default value used by -- 'Network.HTTP.Lucu.Resource.getForm' and such when they are - -- applied to 'Network.HTTP.Lucu.Resource.defaultLimit', so there - -- is no guarantee that this value always constrains all the - -- requests. + -- applied to 'Nothing', so there is no guarantee that this value + -- always constrains all the requests. , cnfMaxEntityLength ∷ !Int -- |Whether to dump too late abortions to the stderr or not. See diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index 06dc8f9..5e48ee4 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -17,17 +17,18 @@ module Network.HTTP.Lucu.Headers ) where import Control.Applicative +import Control.Monad import Data.Ascii (Ascii, AsciiBuilder, CIAscii) import qualified Data.Ascii as A import Data.Attoparsec.Char8 as P import qualified Data.ByteString as BS +import Data.List import Data.Map (Map) import qualified Data.Map as M import qualified Data.Map.Unicode as M import Data.Monoid import Data.Monoid.Unicode import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Utils import Prelude.Unicode newtype Headers @@ -123,9 +124,9 @@ headersP = do xs ← P.many header where header ∷ Parser (CIAscii, Ascii) header = do name ← A.toCIAscii <$> token - _ ← char ':' + void $ char ':' skipMany lws - values ← sepBy content (try lws) + values ← content `sepBy` try lws skipMany (try lws) crlf return (name, joinValues values) @@ -134,11 +135,14 @@ headersP = do xs ← P.many header {-# INLINE content #-} content = A.unsafeFromByteString <$> - takeWhile1 (\c → (¬) (isSPHT c) ∧ isText c) + takeWhile1 (\c → isText c ∧ c ≢ '\x20') joinValues ∷ [Ascii] → Ascii {-# INLINE joinValues #-} - joinValues = A.fromAsciiBuilder ∘ joinWith "\x20" ∘ map A.toAsciiBuilder + joinValues = A.fromAsciiBuilder + ∘ mconcat + ∘ intersperse (A.toAsciiBuilder "\x20") + ∘ map A.toAsciiBuilder printHeaders ∷ Headers → AsciiBuilder printHeaders (Headers m) diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index e486e1a..e871159 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -110,6 +110,7 @@ mkSemanticallyInvalidInteraction ∷ Config → IO SemanticallyInvalidInteraction mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..}) = do date ← getCurrentDate + -- FIXME: DRY let res = setHeader "Server" cnfServerSoftware $ setHeader "Date" date $ setHeader "Content-Type" defaultPageContentType $ diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index f0f93b1..86d7df6 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -135,6 +135,7 @@ serializeExtMap extMap moduleName variableName decls = [ TypeSig (⊥) [name variableName] (TyCon (UnQual (name "ExtMap"))) , nameBind (⊥) (name variableName) extMapExp + , InlineSig (⊥) False AlwaysActive (UnQual (name variableName)) ] comment = concat [ "{- !!! WARNING !!!\n" , " This file is automatically generated.\n" diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index 7d0866c..72eef21 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -11,9 +11,10 @@ module Network.HTTP.Lucu.MultipartForm ) where import Control.Applicative hiding (many) +import Control.Monad import Data.Ascii (Ascii, CIAscii) import qualified Data.Ascii as A -import Data.Attoparsec.Char8 +import Data.Attoparsec import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LS import Data.Map (Map) @@ -22,6 +23,7 @@ import Data.Maybe import Data.Monoid.Unicode import Data.Text (Text) import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.RFC2231 import Prelude.Unicode @@ -60,33 +62,34 @@ printContDispo d multipartFormP ∷ Ascii → Parser [(Text, FormData)] multipartFormP boundary - = do parts ← many $ try $ partP boundary - _ ← string "--" - _ ← string $ A.toByteString boundary - _ ← string "--" + = do void boundaryP + parts ← many $ partP boundaryP + void (string "--" "suffix") crlf catMaybes <$> mapM partToFormPair parts + + "multipartFormP" + where + boundaryP ∷ Parser BS.ByteString + boundaryP = string ("--" ⊕ A.toByteString boundary) + + "boundaryP" -partP ∷ Ascii → Parser Part -partP boundary - = do _ ← string "--" - _ ← string $ A.toByteString boundary - crlf +partP ∷ Parser α → Parser Part +partP boundaryP + = do crlf hs ← headersP d ← getContDispo hs - body ← bodyP boundary + body ← bodyP boundaryP return $ Part hs d body + + "partP" -bodyP ∷ Ascii → Parser LS.ByteString -bodyP boundary - = do body ← manyCharsTill anyChar $ - try $ - do crlf - _ ← string "--" - _ ← string $ A.toByteString boundary - return () - crlf - return body +bodyP ∷ Parser α → Parser LS.ByteString +bodyP boundaryP + = manyOctetsTill anyWord8 (try $ crlf *> boundaryP) + + "bodyP" partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData)) {-# INLINEABLE partToFormPair #-} @@ -138,6 +141,10 @@ getContDispo hdr ]) contDispoP ∷ Parser ContDispo -contDispoP = do dispoType ← A.toCIAscii <$> token - params ← paramsP - return $ ContDispo dispoType params +{-# 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 new file mode 100644 index 0000000..6b935c8 --- /dev/null +++ b/Network/HTTP/Lucu/Parser.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE + BangPatterns + , ScopedTypeVariables + , UnicodeSyntax + #-} +-- |This is an auxiliary parser utilities. You usually don't have to +-- 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 + +-- |@'atMost' n v@ is like @'P.many' v@ but accumulates @v@ at most +-- @n@ times. +atMost ∷ Alternative f ⇒ Int → f a → f [a] +{-# INLINE atMost #-} +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/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs index e3fbf35..72d8ca1 100644 --- a/Network/HTTP/Lucu/Parser/Http.hs +++ b/Network/HTTP/Lucu/Parser/Http.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings - , ScopedTypeVariables , UnicodeSyntax #-} -- |This is an auxiliary parser utilities for parsing things related @@ -25,26 +24,16 @@ module Network.HTTP.Lucu.Parser.Http , separators , quotedStr , qvalue - - , atMost - , manyCharsTill ) where import Control.Applicative -import Control.Applicative.Unicode hiding ((∅)) -import Control.Monad.Unicode +import Control.Monad import Data.Ascii (Ascii) import qualified Data.Ascii as A import Data.Attoparsec.Char8 as P hiding (scan) import qualified Data.Attoparsec.FastSet as FS import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as LS -import qualified Data.ByteString.Lazy.Internal as LS -import Data.Foldable -import Data.Monoid -import Data.Monoid.Unicode -import qualified Data.Sequence as S -import Data.Sequence.Unicode hiding ((∅)) +import Network.HTTP.Lucu.Parser import Prelude.Unicode -- |@'isCtl' c@ returns 'False' iff @0x20 <= c < 0x7F@. @@ -84,20 +73,27 @@ isToken c = (¬) (isCtl c ∨ isSeparator c) -- allows any occurrences of 'lws' before and after each tokens. listOf ∷ Parser a → Parser [a] {-# INLINEABLE listOf #-} -listOf p = do skipMany lws - sepBy p $ do skipMany lws - _ ← char ',' - skipMany lws +listOf p + = do skipMany lws + p `sepBy` do skipMany lws + void $ char ',' + skipMany lws + + "listOf" -- |'token' is almost the same as @'takeWhile1' 'isToken'@ token ∷ Parser Ascii {-# INLINE token #-} -token = A.unsafeFromByteString <$> takeWhile1 isToken +token = (A.unsafeFromByteString <$> takeWhile1 isToken) + + "token" -- |The CRLF: 0x0D 0x0A. crlf ∷ Parser () {-# INLINE crlf #-} -crlf = string "\x0D\x0A" *> return () +crlf = (string "\x0D\x0A" *> return ()) + + "crlf" -- |The SP: 0x20. sp ∷ Parser () @@ -107,9 +103,9 @@ sp = char '\x20' *> return () -- |HTTP LWS: crlf? (sp | ht)+ lws ∷ Parser () {-# INLINEABLE lws #-} -lws = do option () crlf - _ ← takeWhile1 isSPHT - return () +lws = (option () crlf *> void (takeWhile1 isSPHT)) + + "lws" -- |Returns 'True' for SP and HT. isSPHT ∷ Char → Bool @@ -121,106 +117,49 @@ isSPHT _ = False -- |@'separators'@ is almost the same as @'takeWhile1' 'isSeparator'@. separators ∷ Parser Ascii {-# INLINE separators #-} -separators = A.unsafeFromByteString <$> takeWhile1 isSeparator +separators = (A.unsafeFromByteString <$> takeWhile1 isSeparator) + + "separators" -- |'quotedStr' accepts a string surrounded by double quotation -- marks. Quotes can be escaped by backslashes. quotedStr ∷ Parser Ascii {-# INLINEABLE quotedStr #-} -quotedStr = try $ - do _ ← char '"' +quotedStr = do void $ char '"' xs ← P.many (qdtext <|> quotedPair) - _ ← char '"' + void $ char '"' return $ A.unsafeFromByteString $ BS.pack xs + + "quotedStr" where qdtext ∷ Parser Char {-# INLINE qdtext #-} qdtext = satisfy (\c → c ≢ '"' ∧ (¬) (isCtl c)) + + "qdtext" quotedPair ∷ Parser Char {-# INLINE quotedPair #-} - quotedPair = char '\\' *> satisfy isChar + quotedPair = (char '\\' *> satisfy isChar) + + "quotedPair" -- |'qvalue' accepts a so-called qvalue. qvalue ∷ Parser Double {-# INLINEABLE qvalue #-} -qvalue = do x ← char '0' - xs ← option "" $ - do y ← char '.' - ys ← atMost 3 digit - return (y:ys) - return $ read (x:xs) - <|> - do x ← char '1' - xs ← option "" $ - do y ← char '.' - ys ← atMost 3 (char '0') - return (y:ys) - return $ read (x:xs) - --- |@'atMost' n v@ is like @'P.many' v@ but accumulates @v@ at most --- @n@ times. -atMost ∷ Alternative f ⇒ Int → f a → f [a] -{-# INLINE atMost #-} -atMost 0 _ = pure [] -atMost n v = ( (:) <$> v ⊛ atMost (n-1) v ) - <|> - pure [] - -data CharAccumState - = CharAccumState { - casChunks ∷ !(S.Seq BS.ByteString) - , casLastChunk ∷ !(S.Seq Char) - } - -instance Monoid CharAccumState where - mempty - = CharAccumState { - casChunks = (∅) - , casLastChunk = (∅) - } - mappend a b - = b { - casChunks = (casChunks a ⊳ lastChunk a) ⋈ casChunks b - } - -lastChunk ∷ CharAccumState → BS.ByteString -{-# INLINE lastChunk #-} -lastChunk = BS.pack ∘ toList ∘ casLastChunk - -snoc ∷ CharAccumState → Char → CharAccumState -{-# INLINEABLE snoc #-} -snoc cas c - | S.length (casLastChunk cas) ≥ LS.defaultChunkSize - = cas { - casChunks = casChunks cas ⊳ lastChunk cas - , casLastChunk = S.singleton c - } - | otherwise - = cas { - casLastChunk = casLastChunk cas ⊳ c - } - -finish ∷ CharAccumState → LS.ByteString -{-# INLINEABLE finish #-} -finish cas - = let chunks = toList $ casChunks cas ⊳ lastChunk cas - str = LS.fromChunks chunks - in - str - --- |@'manyCharsTill' p end@ takes as many characters untill @p@ --- succeeds. -manyCharsTill ∷ ∀m b. (Monad m, Alternative m) - ⇒ m Char - → m b - → m LS.ByteString -{-# INLINEABLE manyCharsTill #-} -manyCharsTill p end = scan (∅) - where - scan ∷ CharAccumState → m LS.ByteString - {-# INLINE scan #-} - scan s - = (end *> pure (finish s)) - <|> - (scan =≪ (snoc s <$> p)) +qvalue = ( do x ← char '0' + xs ← option "" $ + do y ← char '.' + ys ← atMost 3 digit + return (y:ys) + return $ read (x:xs) + <|> + do x ← char '1' + xs ← option "" $ + do y ← char '.' + ys ← atMost 3 (char '0') + return (y:ys) + return $ read (x:xs) + ) + + "qvalue" diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs index ee929ad..791c891 100644 --- a/Network/HTTP/Lucu/RFC2231.hs +++ b/Network/HTTP/Lucu/RFC2231.hs @@ -17,6 +17,7 @@ module Network.HTTP.Lucu.RFC2231 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) import qualified Data.Ascii as A @@ -46,25 +47,31 @@ import System.IO.Unsafe -- |Convert parameter values to an 'AsciiBuilder'. printParams ∷ Map CIAscii Text → AsciiBuilder -printParams params - | M.null params = (∅) - | otherwise = A.toAsciiBuilder "; " ⊕ - joinWith "; " (map printPair $ M.toList params) +{-# INLINEABLE printParams #-} +printParams m = M.foldlWithKey f (∅) m + -- THINKME: Use foldlWithKey' for newer Data.Map + where + f ∷ AsciiBuilder → CIAscii → Text → AsciiBuilder + {-# INLINE f #-} + f ab k v = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v -printPair ∷ (CIAscii, Text) → AsciiBuilder -printPair (name, value) +printPair ∷ CIAscii → Text → AsciiBuilder +{-# INLINEABLE printPair #-} +printPair name value | T.any (> '\xFF') value = printPairInUTF8 name value | otherwise = printPairInAscii name (A.unsafeFromByteString $ encodeUtf8 value) printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder +{-# INLINEABLE printPairInUTF8 #-} printPairInUTF8 name value = A.toAsciiBuilder (A.fromCIAscii name) ⊕ A.toAsciiBuilder "*=utf-8''" ⊕ escapeUnsafeChars (encodeUtf8 value) (∅) printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder +{-# INLINEABLE printPairInAscii #-} printPairInAscii name value = A.toAsciiBuilder (A.fromCIAscii name) ⊕ A.toAsciiBuilder "=" ⊕ @@ -74,6 +81,7 @@ printPairInAscii name value A.toAsciiBuilder value escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder +{-# INLINEABLE escapeUnsafeChars #-} escapeUnsafeChars bs b = case BS.uncons bs of Nothing → b @@ -84,15 +92,18 @@ escapeUnsafeChars bs b b ⊕ toHex (fromIntegral $ fromEnum c) toHex ∷ Word8 → AsciiBuilder +{-# INLINEABLE toHex #-} toHex o = A.toAsciiBuilder "%" ⊕ A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8) , toHex' (o .&. 0x0F) ]) - -toHex' ∷ Word8 → Char -toHex' o - | o ≤ 0x09 = toEnum $ fromIntegral $ fromEnum '0' + fromIntegral o - | otherwise = toEnum $ fromIntegral $ fromEnum 'A' + fromIntegral (o - 0x0A) - + where + toHex' ∷ Word8 → Char + {-# INLINEABLE toHex' #-} + toHex' h + | h ≤ 0x09 = toEnum $ fromIntegral + $ fromEnum '0' + fromIntegral h + | otherwise = toEnum $ fromIntegral + $ fromEnum 'A' + fromIntegral (h - 0x0A) data ExtendedParam = InitialEncodedParam { @@ -112,19 +123,21 @@ data ExtendedParam } section ∷ ExtendedParam → Integer +{-# INLINE section #-} section (InitialEncodedParam {..}) = 0 section ep = epSection ep -- |'Parser' for parameter values. paramsP ∷ Parser (Map CIAscii Text) +{-# INLINEABLE paramsP #-} paramsP = decodeParams =≪ P.many (try paramP) paramP ∷ Parser ExtendedParam paramP = do skipMany lws - _ ← char ';' + void $ char ';' skipMany lws epm ← nameP - _ ← char '=' + void $ char '=' case epm of (name, 0, True) → do (charset, payload) ← initialEncodedValue @@ -139,22 +152,16 @@ paramP = do skipMany lws nameP ∷ Parser (CIAscii, Integer, Bool) nameP = do name ← (A.toCIAscii ∘ A.unsafeFromByteString) <$> takeWhile1 (\c → isToken c ∧ c ≢ '*') - sect ← option 0 $ - try $ - do _ ← char '*' - n ← decimal - return n - isEncoded ← option False $ - do _ ← char '*' - return True + sect ← option 0 $ try (char '*' *> decimal ) + isEncoded ← option False $ try (char '*' *> pure True) return (name, sect, isEncoded) initialEncodedValue ∷ Parser (CIAscii, BS.ByteString) initialEncodedValue = do charset ← metadata - _ ← char '\'' - _ ← metadata -- Ignore the language tag - _ ← char '\'' + void $ char '\'' + void $ metadata -- Ignore the language tag + void $ char '\'' payload ← encodedPayload if charset ≡ "" then -- NOTE: I'm not sure this is the right thing, but RFC @@ -166,13 +173,15 @@ initialEncodedValue where metadata ∷ Parser CIAscii metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$> - takeWhile (\c → isToken c ∧ c ≢ '\'') + takeWhile (\c → c ≢ '\'' ∧ isToken c) encodedPayload ∷ Parser BS.ByteString +{-# INLINE encodedPayload #-} encodedPayload = BS.concat <$> P.many (hexChar <|> rawChars) hexChar ∷ Parser BS.ByteString -hexChar = do _ ← char '%' +{-# INLINEABLE hexChar #-} +hexChar = do void $ char '%' h ← satisfy isHexChar l ← satisfy isHexChar return $ BS.singleton $ hexToChar h l @@ -181,19 +190,23 @@ isHexChar ∷ Char → Bool isHexChar = inClass "0-9a-fA-F" hexToChar ∷ Char → Char → Char +{-# INLINE hexToChar #-} hexToChar h l = chr $ (hexToInt h `shiftL` 8) .&. hexToInt l hexToInt ∷ Char → Int +{-# INLINEABLE hexToInt #-} hexToInt c | c ≤ '9' = ord c - ord '0' | c ≤ 'F' = ord c - ord 'A' + 10 | otherwise = ord c - ord 'a' + 10 rawChars ∷ Parser BS.ByteString +{-# INLINE rawChars #-} rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%') decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text) +{-# INLINE decodeParams #-} decodeParams = (mapM decodeSections =≪) ∘ sortBySection sortBySection ∷ ∀m. Monad m @@ -213,12 +226,13 @@ sortBySection = flip go (∅) in go xs m' Just s - → case M.insertLookupWithKey (\_ s' _ → s') (section x) x s of - (Nothing, s') - → let m' = M.insert (epName x) s' m + → case M.lookup (section x) s of + Nothing + → let s' = M.insert (section x) x s + m' = M.insert (epName x) s' m in go xs m' - (Just _, _) + Just _ → fail (concat [ "Duplicate section " , show $ section x , " for parameter '" diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index b0af8d1..5a4559e 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -16,6 +16,7 @@ import Control.Monad 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.Monoid.Unicode import qualified Data.Sequence as S @@ -143,6 +144,7 @@ acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsr = do cert ← hGetPeerCert cHandle ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath tid ← spawnResource rsrcDef ni + enqueue ctx ni if reqMustHaveBody arRequest then waitForReceiveBodyReq ctx ni tid input else @@ -209,9 +211,9 @@ wasteAllChunks ctx rsrcTid = go LP.Done input' chunkLen | chunkLen ≡ 0 → gotFinalChunk input' | otherwise → gotChunk input' chunkLen - LP.Fail _ _ msg - → chunkWasMalformed rsrcTid - $ "wasteAllChunks: chunkHeaderP: " ⧺ msg + LP.Fail _ eCtx e + → chunkWasMalformed rsrcTid eCtx e + "wasteAllChunks: chunkHeaderP" go input (InChunk chunkLen) = gotChunk input chunkLen @@ -222,18 +224,18 @@ wasteAllChunks ctx rsrcTid = go case LP.parse chunkFooterP input' of LP.Done input'' _ → go input'' Initial - LP.Fail _ _ msg - → chunkWasMalformed rsrcTid - $ "wasteAllChunks: chunkFooterP: " ⧺ msg + LP.Fail _ eCtx e + → chunkWasMalformed rsrcTid eCtx e + "wasteAllChunks: chunkFooterP" gotFinalChunk ∷ Lazy.ByteString → IO () gotFinalChunk input = case LP.parse chunkTrailerP input of LP.Done input' _ → acceptRequest ctx input' - LP.Fail _ _ msg - → chunkWasMalformed rsrcTid - $ "wasteAllChunks: chunkTrailerP: " ⧺ msg + LP.Fail _ eCtx e + → chunkWasMalformed rsrcTid eCtx e + "wasteAllChunks: chunkTrailerP" readCurrentChunk ∷ HandleLike h ⇒ Context h @@ -253,9 +255,9 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go → gotFinalChunk input' | otherwise → gotChunk input' chunkLen - LP.Fail _ _ msg - → chunkWasMalformed rsrcTid - $ "readCurrentChunk: chunkHeaderP: " ⧺ msg + LP.Fail _ eCtx e + → chunkWasMalformed rsrcTid eCtx e + "readCurrentChunk: chunkHeaderP" go input (InChunk chunkLen) = gotChunk input chunkLen @@ -271,9 +273,9 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go case LP.parse chunkFooterP input' of LP.Done input'' _ → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial - LP.Fail _ _ msg - → chunkWasMalformed rsrcTid - $ "readCurrentChunk: chunkFooterP: " ⧺ msg + LP.Fail _ eCtx e + → chunkWasMalformed rsrcTid eCtx e + "readCurrentChunk: chunkFooterP: " else waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen' @@ -283,15 +285,20 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go case LP.parse chunkTrailerP input of LP.Done input' _ → acceptRequest ctx input' - LP.Fail _ _ msg - → chunkWasMalformed rsrcTid - $ "readCurrentChunk: chunkTrailerP: " ⧺ msg + LP.Fail _ eCtx e + → chunkWasMalformed rsrcTid eCtx e + "readCurrentChunk: chunkTrailerP" -chunkWasMalformed ∷ ThreadId → String → IO () -chunkWasMalformed tid msg +chunkWasMalformed ∷ ThreadId → [String] → String → String → IO () +chunkWasMalformed tid eCtx e msg = let abo = mkAbortion BadRequest [("Connection", "close")] $ Just - $ "chunkWasMalformed: " ⊕ T.pack msg + $ "chunkWasMalformed: " + ⊕ T.pack msg + ⊕ ": " + ⊕ T.pack (intercalate ", " eCtx) + ⊕ ": " + ⊕ T.pack e in throwTo tid abo diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index d61f2f4..71ff483 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,5 +1,6 @@ {-# LANGUAGE - GeneralizedNewtypeDeriving + BangPatterns + , GeneralizedNewtypeDeriving , DoAndIfThenElse , OverloadedStrings , RecordWildCards @@ -136,7 +137,9 @@ module Network.HTTP.Lucu.Resource , putBuilder ) where -import qualified Blaze.ByteString.Builder.ByteString as BB +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.Monad import Control.Monad.IO.Class @@ -148,14 +151,11 @@ import qualified Data.Attoparsec.Lazy as LP import Data.ByteString (ByteString) import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy -import qualified Data.ByteString.Lazy.Internal as Lazy -import Data.Foldable (toList) import Data.List import qualified Data.Map as M import Data.Maybe +import Data.Monoid import Data.Monoid.Unicode -import Data.Sequence (Seq) -import Data.Sequence.Unicode hiding ((∅)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -552,24 +552,23 @@ getChunks Nothing getChunks' ∷ Int → Resource Lazy.ByteString getChunks' limit = go limit (∅) where - go ∷ Int → Seq Strict.ByteString → Resource Lazy.ByteString - go 0 _ = do chunk ← getChunk 1 - if Strict.null chunk then - return (∅) - else - abort $ mkAbortion' RequestEntityTooLarge - $ "Request body must be smaller than " - ⊕ T.pack (show limit) - ⊕ " bytes." - go n xs = do let n' = min n Lazy.defaultChunkSize - chunk ← getChunk n' - if Strict.null chunk then - -- Got EOF - return $ Lazy.fromChunks $ toList xs - else - do let n'' = n' - Strict.length chunk - xs' = xs ⊳ chunk - go n'' xs' + go ∷ Int → Builder → Resource Lazy.ByteString + go 0 _ = do chunk ← getChunk 1 + if Strict.null chunk then + return (∅) + else + abort $ mkAbortion' RequestEntityTooLarge + $ "Request body must be smaller than " + ⊕ T.pack (show limit) + ⊕ " bytes." + go !n !b = do c ← getChunk $ min n BB.defaultBufferSize + if Strict.null c then + -- Got EOF + return $ BB.toLazyByteString b + else + do let n' = n - Strict.length c + xs' = b ⊕ BB.fromByteString c + go n' xs' -- |@'getForm' limit@ attempts to read the request body with -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or @@ -624,7 +623,12 @@ getForm limit case LP.parse (p b) src of LP.Done _ formList → return formList - _ → abort $ mkAbortion' BadRequest "Unparsable multipart/form-data" + 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 @@ -674,7 +678,10 @@ setContentEncoding codings _ → abort $ mkAbortion' InternalServerError "setContentEncoding: Unknown HTTP version" setHeader "Content-Encoding" - (A.fromAsciiBuilder $ joinWith ", " $ map tr codings) + $ A.fromAsciiBuilder + $ mconcat + $ intersperse (A.toAsciiBuilder ", ") + $ map tr codings where toAB = A.toAsciiBuilder ∘ A.fromCIAscii diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index e8aa3ef..9df36a6 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -41,6 +41,7 @@ import qualified Data.Ascii as A import qualified Data.ByteString as Strict import Data.List import Data.Maybe +import Data.Monoid import Data.Monoid.Unicode import qualified Data.Text as T import Network.HTTP.Lucu.Abortion @@ -52,7 +53,6 @@ import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Utils import Network.Socket import OpenSSL.X509 import Prelude hiding (catch) @@ -166,12 +166,12 @@ spawnResource (ResourceDef {..}) ni@(NI {..}) _ → error $ "Unknown request method: " ⧺ show (reqMethod req) notAllowed ∷ Resource () - notAllowed - = setStatus MethodNotAllowed - *> - (setHeader "Allow" $ A.fromAsciiBuilder - $ joinWith ", " - $ map A.toAsciiBuilder allowedMethods) + notAllowed = do setStatus MethodNotAllowed + setHeader "Allow" + $ A.fromAsciiBuilder + $ mconcat + $ intersperse (A.toAsciiBuilder ", ") + $ map A.toAsciiBuilder allowedMethods allowedMethods ∷ [Ascii] allowedMethods = nub $ concat [ methods resGet ["GET"] diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index f0e9bd8..4f66931 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -46,7 +46,8 @@ staticFile path } octetStream ∷ MIMEType -octetStream = mkMIMEType "application" "octet-stream" +{-# NOINLINE octetStream #-} +octetStream = parseMIMEType "application/octet-stream" handleStaticFile ∷ Bool → FilePath → Resource () handleStaticFile sendContent path diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 4db7c05..7dbb116 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -6,7 +6,6 @@ -- functions may be useful too for something else. module Network.HTTP.Lucu.Utils ( splitBy - , joinWith , quoteStr , parseWWWFormURLEncoded , splitPathInfo @@ -31,21 +30,9 @@ import Prelude.Unicode splitBy ∷ (a → Bool) → [a] → [[a]] {-# INLINEABLE splitBy #-} splitBy isSep src - = case break isSep src - of (last , [] ) → [last] - (first, _sep:rest) → first : splitBy isSep rest - --- |> joinWith ":" ["ab", "c", "def"] --- > ==> "ab:c:def" -joinWith ∷ Ascii → [AsciiBuilder] → AsciiBuilder -{-# INLINEABLE joinWith #-} -joinWith sep = flip go (∅) - where - go ∷ [AsciiBuilder] → AsciiBuilder → AsciiBuilder - {-# INLINE go #-} - go [] ab = ab - go (x:[]) ab = ab ⊕ x - go (x:xs) ab = go xs (ab ⊕ A.toAsciiBuilder sep ⊕ x) + = case break isSep src of + (last , [] ) → [last] + (first, _sep:rest) → first : splitBy isSep rest -- |> quoteStr "abc" -- > ==> "\"abc\"" diff --git a/examples/Multipart.hs b/examples/Multipart.hs index 9c42e72..8ddc618 100644 --- a/examples/Multipart.hs +++ b/examples/Multipart.hs @@ -21,21 +21,21 @@ resMain ∷ ResourceDef resMain = emptyResource { resGet - = Just $ do setContentType $ mkMIMEType "text" "html" - output ("Multipart Form Test\n" ⊕ - "
\n" ⊕ - " Upload some file:\n" ⊕ - " \n" ⊕ - " \n" ⊕ - " \n" ⊕ - "
\n") + = Just $ do setContentType $ parseMIMEType "text/html" + putChunks $ "Multipart Form Test\n" + ⊕ "
\n" + ⊕ " Upload some file:\n" + ⊕ " \n" + ⊕ " \n" + ⊕ " \n" + ⊕ "
\n" , resPost - = Just $ do form ← inputForm defaultLimit + = Just $ do form ← getForm Nothing let text = fromMaybe (∅) $ fdContent <$> lookup "text" form file = fromMaybe (∅) $ fdContent <$> lookup "file" form fileName = fdFileName =≪ lookup "file" form - setContentType $ mkMIMEType "text" "plain" - outputChunk ("You entered \"" ⊕ text ⊕ "\".\n") - outputChunk ("You uploaded a " ⊕ Lazy.pack (show $ Lazy.length file) ⊕ " bytes long file.\n") - output ("The file name is " ⊕ Lazy.pack (show fileName) ⊕ ".\n") + setContentType $ parseMIMEType "text/plain" + putChunks $ "You entered \"" ⊕ text ⊕ "\".\n" + putChunks $ "You uploaded a " ⊕ Lazy.pack (show $ Lazy.length file) ⊕ " bytes long file.\n" + putChunks $ "The file name is " ⊕ Lazy.pack (show fileName) ⊕ ".\n" } -- 2.40.0