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."
]
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)
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
= 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
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
lastModifiedDecl lastMod
= [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime")))
, nameBind (⊥) varName valExp
+ , InlineSig (⊥) False AlwaysActive (UnQual varName)
]
where
varName ∷ Name
contentTypeDecl mime
= [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType")))
, nameBind (⊥) varName valExp
+ , InlineSig (⊥) False AlwaysActive (UnQual varName)
]
where
varName ∷ Name
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
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..."
壓縮される場合は次のやうに變はる:
------------------------------------------------------------------------------
-- 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
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
, 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..."
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
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
-- |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
)
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
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)
{-# 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)
→ IO SemanticallyInvalidInteraction
mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
= do date ← getCurrentDate
+ -- FIXME: DRY
let res = setHeader "Server" cnfServerSoftware $
setHeader "Date" date $
setHeader "Content-Type" defaultPageContentType $
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"
)
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)
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
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 #-}
])
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"
--- /dev/null
+{-# 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))
{-# LANGUAGE
OverloadedStrings
- , ScopedTypeVariables
, UnicodeSyntax
#-}
-- |This is an auxiliary parser utilities for parsing things related
, 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@.
-- 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 ()
-- |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
-- |@'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"
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
-- |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 "=" ⊕
A.toAsciiBuilder value
escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
+{-# INLINEABLE escapeUnsafeChars #-}
escapeUnsafeChars bs b
= case BS.uncons bs of
Nothing → 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 {
}
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
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
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
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
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 '"
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
= 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
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
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
→ 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
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'
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
{-# LANGUAGE
- GeneralizedNewtypeDeriving
+ BangPatterns
+ , GeneralizedNewtypeDeriving
, DoAndIfThenElse
, OverloadedStrings
, RecordWildCards
, 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
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
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
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
_ → 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
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
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)
_ → 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"]
}
octetStream ∷ MIMEType
-octetStream = mkMIMEType "application" "octet-stream"
+{-# NOINLINE octetStream #-}
+octetStream = parseMIMEType "application/octet-stream"
handleStaticFile ∷ Bool → FilePath → Resource ()
handleStaticFile sendContent path
-- functions may be useful too for something else.
module Network.HTTP.Lucu.Utils
( splitBy
- , joinWith
, quoteStr
, parseWWWFormURLEncoded
, splitPathInfo
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\""
resMain
= emptyResource {
resGet
- = Just $ do setContentType $ mkMIMEType "text" "html"
- output ("<title>Multipart Form Test</title>\n" ⊕
- "<form action=\"/\" method=\"post\" enctype=\"multipart/form-data\">\n" ⊕
- " Upload some file:\n" ⊕
- " <input type=\"text\" name=\"text\">\n" ⊕
- " <input type=\"file\" name=\"file\">\n" ⊕
- " <input type=\"submit\" value=\"Submit\">\n" ⊕
- "</form>\n")
+ = Just $ do setContentType $ parseMIMEType "text/html"
+ putChunks $ "<title>Multipart Form Test</title>\n"
+ ⊕ "<form action=\"/\" method=\"post\" enctype=\"multipart/form-data\">\n"
+ ⊕ " Upload some file:\n"
+ ⊕ " <input type=\"text\" name=\"text\">\n"
+ ⊕ " <input type=\"file\" name=\"file\">\n"
+ ⊕ " <input type=\"submit\" value=\"Submit\">\n"
+ ⊕ "</form>\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"
}
projects / Lucu.git / commitdiff