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
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
putChunksStmt = qualStmt ∘ putChunksExp
entityTagDecl ∷ ETag → [Decl]
-entityTagDecl eTag
+entityTagDecl tag
= [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag")))
, nameBind (⊥) varName valExp
]
varName = name "entityTag"
valExp ∷ Exp
- valExp = function "parseETag" `app` strE (eTagToString eTag)
+ valExp = function "parseETag" `app` strE (eTagToString tag)
lastModifiedDecl ∷ UTCTime → [Decl]
lastModifiedDecl lastMod
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"
" 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"
, " -}"
]
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.*,
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
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
, Password
, printAuthChallenge
- , authCredentialP
+ , authCredential
)
where
import Control.Monad
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
UnicodeSyntax
#-}
module Network.HTTP.Lucu.Chunk
- ( chunkHeaderP
- , chunkFooterP
- , chunkTrailerP
+ ( chunkHeader
+ , chunkFooter
+ , chunkTrailer
)
where
import Control.Applicative
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
char '=' *>
(token <|> quotedStr) )
-chunkFooterP ∷ Parser ()
-chunkFooterP = crlf
+chunkFooter ∷ Parser ()
+chunkFooter = crlf
-chunkTrailerP ∷ Parser Headers
-chunkTrailerP = headersP
+chunkTrailer ∷ Parser Headers
+chunkTrailer = headers
module Network.HTTP.Lucu.ContentCoding
( AcceptEncoding(..)
- , acceptEncodingListP
+ , acceptEncodingList
, normalizeCoding
, unnormalizeCoding
)
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
, strongETag
, weakETag
- , eTagP
- , eTagListP
+ , eTag
+ , eTagList
)
where
import Control.Applicative
where
p ∷ Parser ETag
{-# INLINE p #-}
- p = do et ← eTagP
+ p = do et ← eTag
endOfInput
return et
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
, toHeaders
, fromHeaders
- , headersP
+ , headers
, printHeaders
)
where
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
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)
-- 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))
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
= SEI {
seiRequest ∷ !Request
, seiExpectedContinue ∷ !Bool
- , seiReqBodyLength ∷ !(S.Maybe RequestBodyLength)
+ , seiReqBodyLength ∷ !(Maybe RequestBodyLength)
, seiResponse ∷ !Response
, seiWillChunkBody ∷ !Bool
, niRequest ∷ !Request
, niResourcePath ∷ ![Strict.ByteString]
, niExpectedContinue ∷ !Bool
- , niReqBodyLength ∷ !(S.Maybe RequestBodyLength)
+ , niReqBodyLength ∷ !(Maybe RequestBodyLength)
, niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
, niReceivedBody ∷ !(TMVar Strict.ByteString)
, parseMIMEType
, printMIMEType
- , mimeTypeP
- , mimeTypeListP
+ , mimeType
+ , mimeTypeList
)
where
import Control.Applicative
= 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.
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
)
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
→ 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
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)
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)
{-# LANGUAGE
DoAndIfThenElse
+ , FlexibleContexts
, OverloadedStrings
, RecordWildCards
, ScopedTypeVariables
, UnicodeSyntax
#-}
+-- |Parse \"multipart/form-data\" based on RFC 2388:
+-- <http://www.faqs.org/rfcs/rfc2388.html>
+--
+-- 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
= 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
+-- <http://www.faqs.org/rfcs/rfc2047.html>, 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"
-- 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.
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))
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
, arWillDiscardBody ∷ !Bool
, arWillClose ∷ !Bool
, arExpectedContinue ∷ !Bool
- , arReqBodyLength ∷ !(S.Maybe RequestBodyLength)
+ , arReqBodyLength ∷ !(Maybe RequestBodyLength)
}
data RequestBodyLength
, arWillDiscardBody = False
, arWillClose = False
, arExpectedContinue = False
- , arReqBodyLength = S.Nothing
+ , arReqBodyLength = Nothing
}
go ∷ State AugmentedRequest ()
go = do examineHttpVersion
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 }
| v ≡ "identity"
→ return ()
| v ≡ "chunked"
- → setBodyLength $ S.Just Chunked
+ → setBodyLength $ Just Chunked
| otherwise
→ setStatus NotImplemented
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
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
DoAndIfThenElse
, OverloadedStrings
, RecordWildCards
- , ScopedTypeVariables
, UnicodeSyntax
#-}
-- |Provide functionalities to encode/decode MIME parameter values in
--
-- 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)
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
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
-- 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
{-# 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
, "'"
])
-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)
, "'"
])
- 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
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
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)
( Method(..)
, Request(..)
, reqMustHaveBody
- , requestP
+ , request
)
where
import Control.Applicative
| 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
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 ((∅))
-- リクエストを讀む。パースできない場合は直ちに 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
→ 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
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
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
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'
→ gotChunk input' chunkLen
LP.Fail _ eCtx e
→ chunkWasMalformed rsrcTid eCtx e
- "readCurrentChunk: chunkHeaderP"
+ "readCurrentChunk: chunkHeader"
go input (InChunk chunkLen)
= gotChunk input chunkLen
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
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
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
-- |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
-- |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 ∘
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
Left _ → abort $ mkAbortion' BadRequest
$ "Unparsable Accept: " ⊕ A.toText accept
where
- p = do xs ← mimeTypeListP
+ p = do xs ← mimeTypeList
P.endOfInput
return xs
Left _ → abort $ mkAbortion' BadRequest
$ "Unparsable Accept-Encoding: " ⊕ A.toText ae
where
- p = do xs ← acceptEncodingListP
+ p = do xs ← acceptEncodingList
P.endOfInput
return xs
Left _ → abort $ mkAbortion' BadRequest
$ "Unparsable Content-Type: " ⊕ A.toText cType
where
- p = do t ← mimeTypeP
+ p = do t ← mimeType
P.endOfInput
return t
Right ac → return $ Just ac
Left _ → return Nothing
where
- p = do ac ← authCredentialP
+ p = do ac ← authCredential
P.endOfInput
return ac
driftTo ReceivingBody
where
- p = do xs ← eTagListP
+ p = do xs ← eTagList
P.endOfInput
return xs
{-# 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
-- 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
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
-- 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 {..})
-- |@'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 {..})
-- \"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 {..})
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
, isError
, isClientError
, isServerError
-
- , statusCode
)
where
import Data.Ascii (Ascii, AsciiBuilder)
{-# 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 #-}
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.
| 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.
--- !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.
- PHO <pho@cielonegro.org>
- created
- ""
+- - 2011-10-27 17:33:31.904875 Z
+ - PHO <pho@cielonegro.org>
+ - edited title
+ - Should be defaulted to off!
git_branch:
#!/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
projects / Lucu.git / commitdiff