-- |Class of types which have their corresponding parsers.
--
--- Minimal complete definition: 'parse'
+-- Minimal complete definition: 'parser'
class Parsable t a where
- parse :: Parser t a
+ parser :: Parser t a
instance Parsable B.ByteString Word8 where
- {-# INLINE CONLIKE parse #-}
- parse = B.anyWord8
+ {-# INLINE CONLIKE parser #-}
+ parser = B.anyWord8
instance Parsable B.ByteString Char where
- {-# INLINE CONLIKE parse #-}
- parse = B.anyChar
+ {-# INLINE CONLIKE parser #-}
+ parser = B.anyChar
instance Parsable B.ByteString B.ByteString where
- {-# INLINE CONLIKE parse #-}
- parse = B.takeByteString
+ {-# INLINE CONLIKE parser #-}
+ parser = B.takeByteString
instance Parsable B.ByteString LB.ByteString where
- {-# INLINE CONLIKE parse #-}
- parse = B.takeLazyByteString
+ {-# INLINE CONLIKE parser #-}
+ parser = B.takeLazyByteString
instance Parsable B.ByteString Double where
- {-# INLINE CONLIKE parse #-}
- parse = B.double
+ {-# INLINE CONLIKE parser #-}
+ parser = B.double
instance Parsable B.ByteString Number where
- {-# INLINE CONLIKE parse #-}
- parse = B.number
+ {-# INLINE CONLIKE parser #-}
+ parser = B.number
instance Parsable T.Text Char where
- {-# INLINE CONLIKE parse #-}
- parse = T.anyChar
+ {-# INLINE CONLIKE parser #-}
+ parser = T.anyChar
instance Parsable T.Text T.Text where
- {-# INLINE CONLIKE parse #-}
- parse = T.takeText
+ {-# INLINE CONLIKE parser #-}
+ parser = T.takeText
instance Parsable T.Text LT.Text where
- {-# INLINE CONLIKE parse #-}
- parse = T.takeLazyText
+ {-# INLINE CONLIKE parser #-}
+ parser = T.takeLazyText
instance Parsable T.Text Double where
- {-# INLINE CONLIKE parse #-}
- parse = T.double
+ {-# INLINE CONLIKE parser #-}
+ parser = T.double
instance Parsable T.Text Number where
- {-# INLINE CONLIKE parse #-}
- parse = T.number
+ {-# INLINE CONLIKE parser #-}
+ parser = T.number
Network.HTTP.Lucu.MIMEType
Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
Network.HTTP.Lucu.MIMEType.Guess
- Network.HTTP.Lucu.MIMEType.TH
Network.HTTP.Lucu.MultipartForm
Network.HTTP.Lucu.Parser.Http
Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.ETag
import Network.HTTP.Lucu.Httpd
import Network.HTTP.Lucu.MIMEParams
-import Network.HTTP.Lucu.MIMEType hiding (mimeType)
-import Network.HTTP.Lucu.MIMEType.TH
+import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Resource
import Network.HTTP.Lucu.Response
, Realm
, UserID
, Password
- , authCredential
)
where
import Control.Monad
import Data.Ascii (Ascii, AsciiBuilder)
import Data.Attempt
import Data.Attoparsec.Char8
+import Data.Attoparsec.Parsable
import qualified Data.ByteString.Base64 as B64
+import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import Data.Convertible.Base
import Data.Convertible.Instances.Ascii ()
, ([t| AuthChallenge |], [t| AsciiBuilder |])
]
--- |'Parser' for an 'AuthCredential'.
-authCredential ∷ Parser AuthCredential
-authCredential
- = do void $ string "Basic"
- skipMany1 lws
- b64 ← takeWhile1 base64
- case C8.break (≡ ':') (B64.decodeLenient b64) of
- (user, cPassword)
- | C8.null cPassword
- → fail "no colons in the basic auth credential"
- | otherwise
- → do u ← asc user
- p ← asc (C8.tail cPassword)
- return (BasicAuthCredential u p)
- where
- base64 ∷ Char → Bool
- base64 = inClass "a-zA-Z0-9+/="
+instance Parsable ByteString AuthCredential where
+ parser = do void $ string "Basic"
+ skipMany1 lws
+ b64 ← takeWhile1 base64
+ case C8.break (≡ ':') (B64.decodeLenient b64) of
+ (user, cPassword)
+ | C8.null cPassword
+ → fail "no colons in the basic auth credential"
+ | otherwise
+ → do u ← asc user
+ p ← asc (C8.tail cPassword)
+ return (BasicAuthCredential u p)
+ where
+ base64 ∷ Char → Bool
+ base64 = inClass "a-zA-Z0-9+/="
- asc ∷ C8.ByteString → Parser Ascii
- asc bs = case ca bs of
- Success as → return as
- Failure _ → fail "Non-ascii character in auth credential"
+ asc ∷ C8.ByteString → Parser Ascii
+ asc bs
+ = case ca bs of
+ Success as → return as
+ Failure _ → fail "Non-ascii character in auth credential"
where
import Control.Applicative
import Data.Attoparsec.Char8
+import Data.Attoparsec.Parsable
import Data.Bits
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.Parser.Http
chunkFooter = crlf
chunkTrailer ∷ Parser Headers
-chunkTrailer = headers
+chunkTrailer = parser
{-# LANGUAGE
- OverloadedStrings
+ FlexibleInstances
+ , MultiParamTypeClasses
+ , OverloadedStrings
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.ContentCoding
( AcceptEncoding(..)
-
- , acceptEncodingList
, normalizeCoding
, unnormalizeCoding
)
import Control.Applicative
import Data.Ascii (CIAscii, toCIAscii)
import Data.Attoparsec.Char8
+import Data.Attoparsec.Parsable
+import Data.ByteString (ByteString)
import Data.Ord
import Data.Maybe
import Network.HTTP.Lucu.Parser.Http
q1' = fromMaybe 0 q1
q2' = fromMaybe 0 q2
-acceptEncodingList ∷ Parser [AcceptEncoding]
-acceptEncodingList = listOf accEnc
+instance Parsable ByteString [AcceptEncoding] where
+ {-# INLINE parser #-}
+ parser = listOf parser
-accEnc ∷ Parser AcceptEncoding
-accEnc = do coding ← toCIAscii <$> token
- qVal ← option Nothing
- $ do _ ← string ";q="
- q ← qvalue
- return $ Just q
- return $ AcceptEncoding (normalizeCoding coding) qVal
+instance Parsable ByteString AcceptEncoding where
+ {-# INLINE parser #-}
+ parser = do coding ← toCIAscii <$> token
+ qVal ← option Nothing
+ $ do _ ← string ";q="
+ q ← qvalue
+ return $ Just q
+ return $ AcceptEncoding (normalizeCoding coding) qVal
normalizeCoding ∷ CIAscii → CIAscii
+{-# INLINEABLE normalizeCoding #-}
normalizeCoding coding
| coding ≡ "x-gzip" = "gzip"
| coding ≡ "x-compress" = "compress"
| otherwise = coding
unnormalizeCoding ∷ CIAscii → CIAscii
+{-# INLINEABLE unnormalizeCoding #-}
unnormalizeCoding coding
| coding ≡ "gzip" = "x-gzip"
| coding ≡ "compress" = "x-compress"
( ETag(..)
, strongETag
, weakETag
- , eTag
- , eTagList
)
where
import Control.Applicative
import Control.Monad
import Data.Ascii (Ascii, AsciiBuilder)
import Data.Attoparsec.Char8
+import Data.Attoparsec.Parsable
+import Data.ByteString (ByteString)
import Data.Convertible.Base
import Data.Convertible.Instances.Ascii ()
import Data.Convertible.Utils
{-# INLINE weakETag #-}
weakETag = ETag True
--- |'Parser' for an 'ETag'.
-eTag ∷ Parser ETag
-{-# INLINEABLE eTag #-}
-eTag = do isWeak ← option False (string "W/" *> return True)
- str ← quotedStr
- return $ ETag isWeak str
+instance Parsable ByteString ETag where
+ {-# INLINEABLE parser #-}
+ parser = do isWeak ← option False (string "W/" *> return True)
+ str ← quotedStr
+ return $ ETag isWeak str
--- |'Parser' for a list of 'ETag's.
-eTagList ∷ Parser [ETag]
-{-# INLINEABLE eTagList #-}
-eTagList = do xs ← listOf eTag
- when (null xs) $
- fail "empty list of ETags"
- return xs
+instance Parsable ByteString [ETag] where
+ {-# INLINEABLE parser #-}
+ parser = do xs ← listOf parser
+ when (null xs) $
+ fail "empty list of ETags"
+ return xs
module Network.HTTP.Lucu.Headers
( Headers
, HasHeaders(..)
- , headers
)
where
import Control.Applicative hiding (empty)
import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
import qualified Data.Ascii as A
import Data.Attoparsec.Char8
+import Data.Attoparsec.Parsable
+import Data.ByteString (ByteString)
import qualified Data.Collections.Newtype.TH as C
import Data.Convertible.Base
import Data.Convertible.Instances.Ascii ()
field-value の先頭および末尾にある LWS は全て削除され、それ以外の
LWS は單一の SP に變換される。
-}
-headers ∷ Parser Headers
-{-# INLINEABLE headers #-}
-headers = do xs ← many header
- crlf
- return $ fromFoldable xs
- where
- header ∷ Parser (CIAscii, Ascii)
- header = do name ← cs <$> token
- void $ char ':'
- skipMany lws
- values ← content `sepBy` try lws
- skipMany (try lws)
- crlf
- return (name, joinValues values)
-
- content ∷ Parser Ascii
- {-# INLINE content #-}
- content = A.unsafeFromByteString
- <$>
- takeWhile1 (\c → isText c ∧ c ≢ '\x20')
-
- joinValues ∷ [Ascii] → Ascii
- {-# INLINE joinValues #-}
- joinValues = cs
- ∘ mconcat
- ∘ intersperse (cs ("\x20" ∷ Ascii) ∷ AsciiBuilder)
- ∘ (cs <$>)
+instance Parsable ByteString Headers where
+ {-# INLINEABLE parser #-}
+ parser = do xs ← many header
+ crlf
+ return $ fromFoldable xs
+ where
+ header ∷ Parser (CIAscii, Ascii)
+ {-# INLINEABLE header #-}
+ header = do name ← cs <$> token
+ void $ char ':'
+ skipMany lws
+ values ← content `sepBy` try lws
+ skipMany (try lws)
+ crlf
+ return (name, joinValues values)
+
+ content ∷ Parser Ascii
+ {-# INLINEABLE content #-}
+ content = A.unsafeFromByteString
+ <$>
+ takeWhile1 (\c → isText c ∧ c ≢ '\x20')
+
+ joinValues ∷ [Ascii] → Ascii
+ {-# INLINEABLE joinValues #-}
+ joinValues = cs
+ ∘ mconcat
+ ∘ intersperse (cs ("\x20" ∷ Ascii) ∷ AsciiBuilder)
+ ∘ (cs <$>)
-- |An internal module for HTTP version numbers.
module Network.HTTP.Lucu.HttpVersion
( HttpVersion(..)
- , httpVersion
)
where
import Control.Applicative
import Control.Applicative.Unicode
import Data.Ascii (Ascii, AsciiBuilder)
import Data.Attoparsec.Char8
+import Data.Attoparsec.Parsable
+import Data.ByteString (ByteString)
import Data.Convertible.Base
import Data.Convertible.Instances.Ascii ()
import Data.Convertible.Utils
, ([t| HttpVersion |], [t| AsciiBuilder |])
]
--- |'Parser' for an 'HttpVersion'.
-httpVersion ∷ Parser HttpVersion
-httpVersion = string "HTTP/"
- *>
- (HttpVersion <$> decimal ⊛ (char '.' *> decimal))
+instance Parsable ByteString HttpVersion where
+ {-# INLINEABLE parser #-}
+ parser = string "HTTP/"
+ *>
+ (HttpVersion <$> decimal ⊛ (char '.' *> decimal))
import Data.Maybe
import Data.Time
import Network.HTTP.Lucu.ETag
-import Network.HTTP.Lucu.MIMEType hiding (mimeType)
+import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
import Network.HTTP.Lucu.MIMEType.Guess
-import Network.HTTP.Lucu.MIMEType.TH
import Network.HTTP.Lucu.Utils
import Prelude.Unicode
-- (<http://tools.ietf.org/html/rfc2231>).
module Network.HTTP.Lucu.MIMEParams
( MIMEParams
- , mimeParams
)
where
import Control.Applicative hiding (empty)
import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
import qualified Data.Ascii as A
import Data.Attoparsec.Char8
+import Data.Attoparsec.Parsable
import Data.Bits
+import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.Collections
section (InitialEncodedParam {..}) = 0
section ep = epSection ep
--- |'Parser' for MIME parameter values.
-mimeParams ∷ Parser MIMEParams
-{-# INLINEABLE mimeParams #-}
-mimeParams = decodeParams =≪ many (try paramP)
+instance Parsable ByteString MIMEParams where
+ {-# INLINEABLE parser #-}
+ parser = decodeParams =≪ many (try parser)
-paramP ∷ Parser ExtendedParam
-paramP = do skipMany lws
- void $ char ';'
- skipMany lws
- epm ← nameP
- void $ char '='
- case epm of
- (name, 0, True)
- → do (charset, payload) ← initialEncodedValue
- return $ InitialEncodedParam name charset payload
- (name, sect, True)
- → do payload ← encodedPayload
- return $ ContinuedEncodedParam name sect payload
- (name, sect, False)
- → do payload ← token <|> quotedStr
- return $ AsciiParam name sect payload
+instance Parsable ByteString ExtendedParam where
+ parser = do skipMany lws
+ void $ char ';'
+ skipMany lws
+ epm ← name
+ void $ char '='
+ case epm of
+ (nm, 0, True)
+ → do (charset, payload) ← initialEncodedValue
+ return $ InitialEncodedParam nm charset payload
+ (nm, sect, True)
+ → do payload ← encodedPayload
+ return $ ContinuedEncodedParam nm sect payload
+ (nm, sect, False)
+ → do payload ← token <|> quotedStr
+ return $ AsciiParam nm sect payload
-nameP ∷ Parser (CIAscii, Integer, Bool)
-nameP = do name ← (cs ∘ A.unsafeFromByteString) <$>
- takeWhile1 (\c → isToken c ∧ c ≢ '*')
- sect ← option 0 $ try (char '*' *> decimal )
- isEncoded ← option False $ try (char '*' *> pure True)
- return (name, sect, isEncoded)
+name ∷ Parser (CIAscii, Integer, Bool)
+name = do nm ← (cs ∘ A.unsafeFromByteString) <$>
+ takeWhile1 (\c → isToken c ∧ c ≢ '*')
+ sect ← option 0 $ try (char '*' *> decimal )
+ isEncoded ← option False $ try (char '*' *> pure True)
+ return (nm, sect, isEncoded)
initialEncodedValue ∷ Parser (CIAscii, BS.ByteString)
initialEncodedValue
, RecordWildCards
, TemplateHaskell
, UnicodeSyntax
+ , ViewPatterns
#-}
-- |Parsing and printing MIME Media Types
-- (<http://tools.ietf.org/html/rfc2046>).
module Network.HTTP.Lucu.MIMEType
( MIMEType(..)
, mimeType
- , mimeTypeList
)
where
import Control.Applicative
+import Control.Monad.Unicode
import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
+import Data.Attempt
import Data.Attoparsec.Char8
+import Data.Attoparsec.Parsable
+import Data.ByteString (ByteString)
import Data.Convertible.Base
import Data.Convertible.Instances.Ascii ()
import Data.Convertible.Utils
import Data.Monoid.Unicode
import Data.Typeable
import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Quote
import Network.HTTP.Lucu.MIMEParams
import Network.HTTP.Lucu.OrphanInstances ()
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.Utils
import Prelude.Unicode
-- |A media type, subtype, and parameters.
]
-- |Parse 'MIMEType' from an 'Ascii'. For MIME type literals, consider
--- using 'Network.HTTP.Lucu.MIMEType.TH.mimeType'.
+-- using 'mimeType' quasi-quoter.
instance ConvertAttempt Ascii MIMEType where
{-# INLINEABLE convertAttempt #-}
convertAttempt str
- = case parseOnly (finishOff mimeType) (cs str) of
+ = case parseOnly (finishOff parser) (cs str) of
Right t → return t
Left err → fail ("Unparsable MIME Type: " ⧺ cs str ⧺ ": " ⧺ err)
--- |'Parser' for an 'MIMEType'.
-mimeType ∷ Parser MIMEType
-{-# INLINEABLE mimeType #-}
-mimeType = do media ← cs <$> token
- _ ← char '/'
- sub ← cs <$> token
- params ← mimeParams
- return $ MIMEType media sub params
+instance Parsable ByteString MIMEType where
+ {-# INLINEABLE parser #-}
+ parser = do media ← cs <$> token
+ _ ← char '/'
+ sub ← cs <$> token
+ params ← parser
+ return $ MIMEType media sub params
--- |'Parser' for a list of 'MIMEType's.
-mimeTypeList ∷ Parser [MIMEType]
-{-# INLINE mimeTypeList #-}
-mimeTypeList = listOf mimeType
+instance Parsable ByteString [MIMEType] where
+ {-# INLINE parser #-}
+ parser = listOf parser
+
+-- |'QuasiQuoter' for 'MIMEType' literals.
+--
+-- @
+-- textPlain :: 'MIMEType'
+-- textPlain = ['mimeType'| text/plain; charset=\"UTF-8\" |]
+-- @
+mimeType ∷ QuasiQuoter
+mimeType = QuasiQuoter {
+ quoteExp = (lift =≪) ∘ (parseType =≪) ∘ toAscii
+ , quotePat = const unsupported
+ , quoteType = const unsupported
+ , quoteDec = const unsupported
+ }
+ where
+ parseType ∷ Monad m ⇒ Ascii → m MIMEType
+ parseType a
+ = case ca a of
+ Success t → return t
+ Failure e → fail (show e)
+
+ toAscii ∷ Monad m ⇒ String → m Ascii
+ toAscii (trim → s)
+ = case ca s of
+ Success a → return a
+ Failure e → fail (show e)
+
+ unsupported ∷ Monad m ⇒ m α
+ unsupported = fail "Unsupported usage of mimeType quasi-quoter."
{-# LANGUAGE
DeriveDataTypeable
, GeneralizedNewtypeDeriving
+ , MultiParamTypeClasses
, TemplateHaskell
, UnicodeSyntax
, ViewPatterns
module Network.HTTP.Lucu.MIMEType.Guess
( ExtMap(..)
, extMap
- , parseExtMap
, guessTypeByFileName
)
where
import Control.Applicative
import Data.Attoparsec.Char8
import qualified Data.Attoparsec.Lazy as LP
+import Data.Attoparsec.Parsable
import qualified Data.ByteString.Lazy.Char8 as Lazy
import Data.Convertible.Base
import Data.Convertible.Instances.Text ()
, quoteDec = const unsupported
}
where
+ parseExtMap ∷ Lazy.ByteString → ExtMap
+ parseExtMap = convertUnsafe
+
unsupported ∷ Monad m ⇒ m α
unsupported = fail "Unsupported usage of extMap quasi-quoter."
--- |Parse Apache @mime.types@.
-parseExtMap ∷ Lazy.ByteString → ExtMap
-parseExtMap src
- = case LP.parse pairs src of
- LP.Fail _ eCtx e
- → error $ "Unparsable extension map: "
- ⧺ intercalate ", " eCtx
- ⧺ ": "
- ⧺ e
- LP.Done _ xs
- → case compile xs of
- Right m → ExtMap m
- Left e → error ("Duplicate extension: " ⧺ show e)
- where
- pairs ∷ Parser [(MIMEType, [Text])]
- pairs = do skipMany linebreak
- xs ← sepBy pair (skipMany1 linebreak)
- skipMany linebreak
- endOfInput
- return xs
- <?>
- "pairs"
+instance ConvertAttempt Lazy.ByteString ExtMap where
+ convertAttempt src
+ = case LP.parse pairs src of
+ LP.Fail _ eCtx e
+ → fail $ "Unparsable extension map: "
+ ⊕ intercalate ", " eCtx
+ ⊕ ": "
+ ⊕ e
+ LP.Done _ xs
+ → case compile xs of
+ Right m → return $ ExtMap m
+ Left e → fail $ "Duplicate extension: " ⊕ show e
+ where
+ pairs ∷ Parser [(MIMEType, [Text])]
+ pairs = do skipMany linebreak
+ xs ← sepBy pair (skipMany1 linebreak)
+ skipMany linebreak
+ endOfInput
+ return xs
+ <?>
+ "pairs"
- pair ∷ Parser (MIMEType, [Text])
- pair = do skipSpace
- mime ← mimeType
- skipSpace1
- exts ← sepBy1 ext $ skipWhile1 (≡ '\x20')
- return (mime, exts)
- <?>
- "pair"
+ pair ∷ Parser (MIMEType, [Text])
+ pair = do skipSpace
+ mime ← parser
+ skipSpace1
+ exts ← sepBy1 ext $ skipWhile1 (≡ '\x20')
+ return (mime, exts)
+ <?>
+ "pair"
- ext ∷ Parser Text
- ext = (decodeUtf8 <$> takeWhile1 isAlphaNum)
- <?>
- "ext"
+ ext ∷ Parser Text
+ ext = (decodeUtf8 <$> takeWhile1 isAlphaNum)
+ <?>
+ "ext"
- linebreak ∷ Parser ()
- linebreak
- = ( endOfLine
- <|>
- try (skipSpace *> char '#' *> skipManyTill anyChar endOfLine)
- )
- <?>
- "linebreak"
+ linebreak ∷ Parser ()
+ linebreak
+ = ( endOfLine
+ <|>
+ try (skipSpace *> char '#' *> skipManyTill anyChar endOfLine)
+ )
+ <?>
+ "linebreak"
compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
compile = go (∅) ∘ concat ∘ (tr <$>)
+++ /dev/null
-{-# LANGUAGE
- UnicodeSyntax
- , ViewPatterns
- #-}
--- |A module to provide 'QuasiQuoter' for 'MIMEType' literals.
-module Network.HTTP.Lucu.MIMEType.TH
- ( mimeType
- )
- where
-import Control.Monad.Unicode
-import Data.Ascii (Ascii)
-import Data.Attempt
-import Data.Convertible.Base
-import Language.Haskell.TH.Syntax
-import Language.Haskell.TH.Quote
-import Network.HTTP.Lucu.MIMEType hiding (mimeType)
-import Network.HTTP.Lucu.Utils
-import Prelude.Unicode
-
--- |'QuasiQuoter' for 'MIMEType' literals.
---
--- @
--- textPlain :: 'MIMEType'
--- textPlain = ['mimeType'| text/plain; charset=\"UTF-8\" |]
--- @
-mimeType ∷ QuasiQuoter
-mimeType = QuasiQuoter {
- quoteExp = (lift =≪) ∘ (parse =≪) ∘ toAscii
- , quotePat = const unsupported
- , quoteType = const unsupported
- , quoteDec = const unsupported
- }
- where
- parse ∷ Monad m ⇒ Ascii → m MIMEType
- parse a
- = case ca a of
- Success t → return t
- Failure e → fail (show e)
-
- toAscii ∷ Monad m ⇒ String → m Ascii
- toAscii (trim → s)
- = case ca s of
- Success a → return a
- Failure e → fail (show e)
-
- unsupported ∷ Monad m ⇒ m α
- unsupported = fail "Unsupported usage of mimeType quasi-quoter."
import Data.Attempt
import Data.Attoparsec
import qualified Data.Attoparsec.Lazy as LP
+import Data.Attoparsec.Parsable
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LS
import Data.ByteString.Lazy.Search
import Data.Text (Text)
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.MIMEParams
-import Network.HTTP.Lucu.MIMEType (MIMEType)
-import qualified Network.HTTP.Lucu.MIMEType as MT
-import Network.HTTP.Lucu.MIMEType.TH
+import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.Utils
, ([t| ContDispo |], [t| AsciiBuilder |])
]
--- |Parse \"multipart/form-data\" and return either @'Left' err@ or
--- @'Right' result@. Note that there are currently the following
+-- |Parse \"multipart/form-data\" to a list of @(name,
+-- formData)@. Note that there are currently the following
-- limitations:
--
-- * Multiple files embedded as \"multipart/mixed\" within the
-- * \"Content-Transfer-Encoding\" is always ignored.
--
-- * RFC 2388 (<http://tools.ietf.org/html/rfc2388#section-3>) says
--- that non-ASCII field names are encoded according to the method in
--- RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but they won't
--- be decoded.
+-- that non-ASCII field names are encoded according to the method
+-- in RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but this
+-- function currently doesn't decode them.
parseMultipartFormData ∷ Ascii -- ^boundary
→ LS.ByteString -- ^input
→ Either String [(Ascii, FormData)]
defaultCType = [mimeType| text/plain |]
partHeader ∷ Parser Headers
-partHeader = crlf *> headers
+partHeader = crlf *> parser
getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
{-# INLINEABLE getContDispo #-}
contentDisposition ∷ Parser ContDispo
contentDisposition
- = (ContDispo <$> (cs <$> token) ⊛ mimeParams)
+ = (ContDispo <$> (cs <$> token) ⊛ parser)
<?>
"contentDisposition"
Nothing
→ return Nothing
Just str
- → case parseOnly (finishOff MT.mimeType) $ cs str of
+ → case parseOnly (finishOff parser) $ cs str of
Right d → return $ Just d
Left err → throwError $ "malformed Content-Type: "
⊕ cs str
{-# LANGUAGE
- OverloadedStrings
+ MultiParamTypeClasses
+ , OverloadedStrings
, UnicodeSyntax
, ViewPatterns
#-}
( Method(..)
, Request(..)
, reqMustHaveBody
- , request
)
where
import Control.Applicative
import Control.Monad.Unicode
import Data.Ascii (Ascii)
import Data.Attoparsec.Char8
+import Data.Attoparsec.Parsable
+import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
| m ≡ PUT = True
| otherwise = False
--- |'Parser' for a 'Request'.
-request ∷ Parser Request
-request = do skipMany crlf
- (meth, u, ver) ← requestLine
- hdrs ← headers
- return Request {
- reqMethod = meth
- , reqURI = u
- , reqVersion = ver
- , reqHeaders = hdrs
- }
+instance Parsable ByteString Request where
+ {-# INLINEABLE parser #-}
+ parser = do skipMany crlf
+ (meth, u, ver) ← requestLine
+ hdrs ← parser
+ return Request {
+ reqMethod = meth
+ , reqURI = u
+ , reqVersion = ver
+ , reqHeaders = hdrs
+ }
requestLine ∷ Parser (Method, URI, HttpVersion)
+{-# INLINEABLE requestLine #-}
requestLine = do meth ← method
sp
u ← uri
sp
- ver ← httpVersion
+ ver ← parser
crlf
return (meth, u, ver)
method ∷ Parser Method
+{-# INLINEABLE method #-}
method = choice
[ string "OPTIONS" ≫ return OPTIONS
, string "GET" ≫ return GET
]
uri ∷ Parser URI
+{-# INLINEABLE uri #-}
uri = do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20'))
let str = C8.unpack bs
case parseURIReference str of
import Control.Monad
import Control.Monad.Trans.Maybe
import qualified Data.Attoparsec.Lazy as LP
+import Data.Attoparsec.Parsable
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import Data.Convertible.Base
if Lazy.null input then
return ()
else
- case LP.parse request input of
+ case LP.parse parser input of
LP.Done input' req → acceptParsableRequest ctx req input'
LP.Fail _ _ _ → acceptNonparsableRequest ctx
import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
import Data.Attempt
import qualified Data.Attoparsec.Char8 as P
+import Data.Attoparsec.Parsable
import Data.ByteString (ByteString)
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.MIMEType (MIMEType(..))
-import qualified Network.HTTP.Lucu.MIMEType as MT
-import Network.HTTP.Lucu.MIMEType.TH
+import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Utils
import Network.Socket hiding (accept)
import Network.URI hiding (path)
Nothing
→ return []
Just accept
- → case P.parseOnly (finishOff MT.mimeTypeList) (cs accept) of
+ → case P.parseOnly (finishOff parser) (cs accept) of
Right xs → return xs
Left _ → abort $ mkAbortion' BadRequest
$ "Unparsable Accept: " ⊕ cs accept
-- identity のみが許される。
return [("identity", Nothing)]
else
- case P.parseOnly (finishOff acceptEncodingList) (cs ae) of
+ case P.parseOnly (finishOff parser) (cs ae) of
Right xs → return $ map toTuple $ reverse $ sort xs
Left _ → abort $ mkAbortion' BadRequest
$ "Unparsable Accept-Encoding: " ⊕ cs ae
Nothing
→ return Nothing
Just cType
- → case P.parseOnly (finishOff MT.mimeType) (cs cType) of
+ → case P.parseOnly (finishOff parser) (cs cType) of
Right t → return $ Just t
Left _ → abort $ mkAbortion' BadRequest
$ "Unparsable Content-Type: " ⊕ cs cType
Nothing
→ return Nothing
Just auth
- → case P.parseOnly (finishOff authCredential) (cs auth) of
+ → case P.parseOnly (finishOff parser) (cs auth) of
Right ac → return $ Just ac
Left _ → return Nothing
→ if value ≡ "*" then
return ()
else
- case P.parseOnly (finishOff eTagList) (cs value) of
+ case P.parseOnly (finishOff parser) (cs value) of
Right tags
-- tags の中に一致するものが無ければ
-- PreconditionFailed で終了。
- → when ((¬) (any (≡ tag) tags))
+ → when ((¬) (any (≡ tag) (tags ∷ [ETag])))
$ abort
$ mkAbortion' PreconditionFailed
$ "The entity tag doesn't match: " ⊕ cs value
abort $ mkAbortion' statusForNoneMatch
$ "The entity tag matches: *"
else
- case P.parseOnly (finishOff eTagList) (cs value) of
+ case P.parseOnly (finishOff parser) (cs value) of
Right tags
- → when (any (≡ tag) tags)
+ → when (any (≡ tag) (tags ∷ [ETag]))
$ abort
$ mkAbortion' statusForNoneMatch
$ "The entity tag matches: " ⊕ cs value
import qualified Data.Text.Encoding as T
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.MIMEType hiding (mimeType)
+import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.MIMEType.Guess
-import Network.HTTP.Lucu.MIMEType.TH
import Network.HTTP.Lucu.Resource
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Response
component: Lucu
release: Lucu-1.0
reporter: PHO <pho@cielonegro.org>
-status: :in_progress
-disposition:
+status: :closed
+disposition: :fixed
creation_time: 2011-12-19 13:01:51.401625 Z
references: []
- PHO <pho@cielonegro.org>
- changed status from unstarted to in_progress
- ""
+- - 2011-12-19 14:29:32.083785 Z
+ - PHO <pho@cielonegro.org>
+ - closed with disposition fixed
+ - Done.
git_branch:
projects / Lucu.git / commitdiff