+++ /dev/null
-{-# LANGUAGE MultiParamTypeClasses #-}
-module Data.Attoparsec.Parsable
- ( Parsable(..)
- )
- where
-import qualified Data.Attoparsec.ByteString as B
-import qualified Data.Attoparsec.ByteString.Char8 as B
-import qualified Data.Attoparsec.Text as T
-import Data.Attoparsec.Number
-import Data.Attoparsec.Types
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as LB
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as LT
-import Data.Word
-
--- |Class of types which have their corresponding parsers.
---
--- Minimal complete definition: 'parser'
-class Parsable t a where
- parser :: Parser t a
-
-instance Parsable B.ByteString Word8 where
- {-# INLINE CONLIKE parser #-}
- parser = B.anyWord8
-
-instance Parsable B.ByteString Char where
- {-# INLINE CONLIKE parser #-}
- parser = B.anyChar
-
-instance Parsable B.ByteString B.ByteString where
- {-# INLINE CONLIKE parser #-}
- parser = B.takeByteString
-
-instance Parsable B.ByteString LB.ByteString where
- {-# INLINE CONLIKE parser #-}
- parser = B.takeLazyByteString
-
-instance Parsable B.ByteString Double where
- {-# INLINE CONLIKE parser #-}
- parser = B.double
-
-instance Parsable B.ByteString Number where
- {-# INLINE CONLIKE parser #-}
- parser = B.number
-
-instance Parsable T.Text Char where
- {-# INLINE CONLIKE parser #-}
- parser = T.anyChar
-
-instance Parsable T.Text T.Text where
- {-# INLINE CONLIKE parser #-}
- parser = T.takeText
-
-instance Parsable T.Text LT.Text where
- {-# INLINE CONLIKE parser #-}
- parser = T.takeLazyText
-
-instance Parsable T.Text Double where
- {-# INLINE CONLIKE parser #-}
- parser = T.double
-
-instance Parsable T.Text Number where
- {-# INLINE CONLIKE parser #-}
- parser = T.number
-DHAVE_SSL
Exposed-Modules:
- Data.Attoparsec.Parsable
Data.Collections.Newtype.TH
Network.HTTP.Lucu
Network.HTTP.Lucu.Abortion
, MultiParamTypeClasses
, OverloadedStrings
, TemplateHaskell
+ , TypeSynonymInstances
, UnicodeSyntax
#-}
-- |An internal module for HTTP authentication.
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 ()
import Data.Convertible.Utils
+import Data.Default
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.Utils
, ([t| AuthChallenge |], [t| AsciiBuilder |])
]
-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)
+instance Default (Parser AuthCredential) where
+ def = 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+/="
where
import Control.Applicative
import Data.Attoparsec.Char8
-import Data.Attoparsec.Parsable
import Data.Bits
+import Data.Default
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.Parser.Http
(token <|> quotedStr) )
chunkFooter ∷ Parser ()
+{-# INLINE chunkFooter #-}
chunkFooter = crlf
chunkTrailer ∷ Parser Headers
-chunkTrailer = parser
+{-# INLINE chunkTrailer #-}
+chunkTrailer = def
{-# LANGUAGE
FlexibleInstances
, MultiParamTypeClasses
+ , TypeSynonymInstances
, OverloadedStrings
, UnicodeSyntax
#-}
import Control.Applicative
import Data.Ascii (CIAscii, toCIAscii)
import Data.Attoparsec.Char8
-import Data.Attoparsec.Parsable
-import Data.ByteString (ByteString)
+import Data.Default
import Data.Ord
import Data.Maybe
import Network.HTTP.Lucu.Parser.Http
q1' = fromMaybe 0 q1
q2' = fromMaybe 0 q2
-instance Parsable ByteString [AcceptEncoding] where
- {-# INLINE parser #-}
- parser = listOf parser
+instance Default (Parser [AcceptEncoding]) where
+ {-# INLINE def #-}
+ def = listOf def
-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
+instance Default (Parser AcceptEncoding) where
+ {-# INLINEABLE def #-}
+ def = 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 #-}
, OverloadedStrings
, RecordWildCards
, TemplateHaskell
+ , TypeSynonymInstances
, UnicodeSyntax
#-}
-- |An internal module for entity tags.
)
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
import Data.Data
+import Data.Default
import Data.Monoid.Unicode
import Language.Haskell.TH.Syntax
import Network.HTTP.Lucu.OrphanInstances ()
{-# INLINE weakETag #-}
weakETag = ETag True
-instance Parsable ByteString ETag where
- {-# INLINEABLE parser #-}
- parser = do isWeak ← option False (string "W/" *> return True)
- str ← quotedStr
- return $ ETag isWeak str
+instance Default (Parser ETag) where
+ {-# INLINEABLE def #-}
+ def = do isWeak ← option False (string "W/" *> return True)
+ str ← quotedStr
+ return $ ETag isWeak str
-instance Parsable ByteString [ETag] where
- {-# INLINEABLE parser #-}
- parser = do xs ← listOf parser
- when (null xs) $
- fail "empty list of ETags"
- return xs
+instance Default (Parser [ETag]) where
+ {-# INLINE def #-}
+ def = listOf def
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 ()
import Data.Convertible.Utils
+import Data.Default
import Data.List (intersperse)
import qualified Data.Map as M (Map)
import Data.Collections
field-value の先頭および末尾にある LWS は全て削除され、それ以外の
LWS は單一の SP に變換される。
-}
-instance Parsable ByteString Headers where
- {-# INLINEABLE parser #-}
- parser = do xs ← many header
- crlf
- return $ fromFoldable xs
+instance Default (Parser Headers) where
+ {-# INLINEABLE def #-}
+ def = do xs ← many header
+ crlf
+ return $ fromFoldable xs
where
header ∷ Parser (CIAscii, Ascii)
{-# INLINEABLE header #-}
, MultiParamTypeClasses
, OverloadedStrings
, TemplateHaskell
+ , TypeSynonymInstances
, UnicodeSyntax
#-}
-- |An internal module for HTTP version numbers.
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
+import Data.Default
import Data.Monoid.Unicode
import Prelude hiding (min)
import Prelude.Unicode
, ([t| HttpVersion |], [t| AsciiBuilder |])
]
-instance Parsable ByteString HttpVersion where
- {-# INLINEABLE parser #-}
- parser = string "HTTP/"
- *>
- (HttpVersion <$> decimal ⊛ (char '.' *> decimal))
+instance Default (Parser HttpVersion) where
+ {-# INLINEABLE def #-}
+ def = string "HTTP/"
+ *>
+ (HttpVersion <$> decimal ⊛ (char '.' *> decimal))
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
import Data.Convertible.Base
import Data.Convertible.Instances.Ascii ()
import Data.Convertible.Utils
+import Data.Default
import qualified Data.Map as M (Map)
import Data.Monoid.Unicode
import Data.Sequence (Seq)
section (InitialEncodedParam {..}) = 0
section ep = epSection ep
-instance Parsable ByteString MIMEParams where
- {-# INLINEABLE parser #-}
- parser = decodeParams =≪ many (try parser)
+instance Default (Parser MIMEParams) where
+ {-# INLINE def #-}
+ def = decodeParams =≪ many (try def)
-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
+instance Default (Parser ExtendedParam) where
+ def = 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
name ∷ Parser (CIAscii, Integer, Bool)
name = do nm ← (cs ∘ A.unsafeFromByteString) <$>
, OverloadedStrings
, RecordWildCards
, TemplateHaskell
+ , TypeSynonymInstances
, UnicodeSyntax
, ViewPatterns
#-}
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.Default
import Data.Monoid.Unicode
import Data.Typeable
import Language.Haskell.TH.Syntax
instance ConvertAttempt Ascii MIMEType where
{-# INLINEABLE convertAttempt #-}
convertAttempt str
- = case parseOnly (finishOff parser) (cs str) of
+ = case parseOnly (finishOff def) (cs str) of
Right t → return t
Left err → fail ("Unparsable MIME Type: " ⧺ cs str ⧺ ": " ⧺ err)
-instance Parsable ByteString MIMEType where
- {-# INLINEABLE parser #-}
- parser = do media ← cs <$> token
- _ ← char '/'
- sub ← cs <$> token
- params ← parser
- return $ MIMEType media sub params
+instance Default (Parser MIMEType) where
+ {-# INLINEABLE def #-}
+ def = do media ← cs <$> token
+ _ ← char '/'
+ sub ← cs <$> token
+ params ← def
+ return $ MIMEType media sub params
-instance Parsable ByteString [MIMEType] where
- {-# INLINE parser #-}
- parser = listOf parser
+instance Default (Parser [MIMEType]) where
+ {-# INLINE def #-}
+ def = listOf def
-- |'QuasiQuoter' for 'MIMEType' literals.
--
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 ()
+import Data.Default
import qualified Data.Map as M
import Data.Map (Map)
import Data.Typeable
pair ∷ Parser (MIMEType, [Text])
pair = do skipSpace
- mime ← parser
+ mime ← def
skipSpace1
exts ← sepBy1 ext $ skipWhile1 (≡ '\x20')
return (mime, exts)
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.Convertible.Base
import Data.Convertible.Instances.Ascii ()
import Data.Convertible.Utils
+import Data.Default
import Data.List (intercalate)
import Data.Maybe
import Data.Monoid.Unicode
defaultCType = [mimeType| text/plain |]
partHeader ∷ Parser Headers
-partHeader = crlf *> parser
+{-# INLINE partHeader #-}
+partHeader = crlf *> def
getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
{-# INLINEABLE getContDispo #-}
⊕ err
contentDisposition ∷ Parser ContDispo
+{-# INLINEABLE contentDisposition #-}
contentDisposition
- = (ContDispo <$> (cs <$> token) ⊛ parser)
+ = (ContDispo <$> (cs <$> token) ⊛ def)
<?>
"contentDisposition"
Nothing
→ return Nothing
Just str
- → case parseOnly (finishOff parser) $ cs str of
+ → case parseOnly (finishOff def) $ cs str of
Right d → return $ Just d
Left err → throwError $ "malformed Content-Type: "
⊕ cs str
{-# LANGUAGE
- MultiParamTypeClasses
+ FlexibleInstances
+ , MultiParamTypeClasses
, OverloadedStrings
+ , TypeSynonymInstances
, UnicodeSyntax
, ViewPatterns
#-}
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 Data.Default
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Parser.Http
| m ≡ PUT = True
| otherwise = False
-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
- }
+instance Default (Parser Request) where
+ {-# INLINEABLE def #-}
+ def = do skipMany crlf
+ (meth, u, ver) ← requestLine
+ hdrs ← def
+ return Request {
+ reqMethod = meth
+ , reqURI = u
+ , reqVersion = ver
+ , reqHeaders = hdrs
+ }
requestLine ∷ Parser (Method, URI, HttpVersion)
{-# INLINEABLE requestLine #-}
sp
u ← uri
sp
- ver ← parser
+ ver ← def
crlf
return (meth, u, ver)
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
import Data.Convertible.Instances.Text ()
+import Data.Default
import Data.List
import Data.Maybe
import Data.Monoid.Unicode
if Lazy.null input then
return ()
else
- case LP.parse parser input of
+ case LP.parse def input of
LP.Done input' req → acceptParsableRequest ctx req input'
LP.Fail _ _ _ → acceptNonparsableRequest ctx
if isError $ arInitialStatus ar then
acceptSemanticallyInvalidRequest ctx ar input
else
- do rsrc ← runMaybeT $ dispatch (reqURI $ arRequest ar) cHostMap
- case rsrc of
+ do rsrcM ← runMaybeT $ dispatch (reqURI $ arRequest ar) cHostMap
+ case rsrcM of
Nothing
→ do let ar' = ar {
arInitialStatus = fromStatusCode NotFound
}
acceptSemanticallyInvalidRequest ctx ar' input
- Just (path, def)
- → acceptRequestForResource ctx ar input path def
+ Just (path, rsrc)
+ → acceptRequestForResource ctx ar input path rsrc
acceptSemanticallyInvalidRequest ∷ HandleLike h
⇒ Context h
→ [Strict.ByteString]
→ Resource
→ IO ()
-acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
+acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrc
= do
#if defined(HAVE_SSL)
cert ← hGetPeerCert cHandle
#else
ni ← mkNormalInteraction cConfig cAddr ar rsrcPath
#endif
- tid ← spawnRsrc rsrcDef ni
+ tid ← spawnRsrc rsrc ni
enqueue ctx ni
if reqHasBody arRequest then
waitForReceiveBodyReq ctx ni tid input
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 Data.Convertible.Base
import Data.Convertible.Instances.Text ()
import Data.Convertible.Utils
+import Data.Default
import Data.List (intersperse, sort)
import Data.Maybe
import Data.Monoid
Nothing
→ return []
Just accept
- → case P.parseOnly (finishOff parser) (cs accept) of
+ → case P.parseOnly (finishOff def) (cs accept) of
Right xs → return xs
Left _ → abort $ mkAbortion' BadRequest
$ "Unparsable Accept: " ⊕ cs accept
-- identity のみが許される。
return [("identity", Nothing)]
else
- case P.parseOnly (finishOff parser) (cs ae) of
+ case P.parseOnly (finishOff def) (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 parser) (cs cType) of
+ → case P.parseOnly (finishOff def) (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 parser) (cs auth) of
+ → case P.parseOnly (finishOff def) (cs auth) of
Right ac → return $ Just ac
Left _ → return Nothing
→ if value ≡ "*" then
return ()
else
- case P.parseOnly (finishOff parser) (cs value) of
+ case P.parseOnly (finishOff def) (cs value) of
+ Right []
+ → abort $ mkAbortion' BadRequest
+ $ "Empty If-Match"
Right tags
-- tags の中に一致するものが無ければ
-- PreconditionFailed で終了。
- → when ((¬) (any (≡ tag) (tags ∷ [ETag])))
+ → when ((¬) (any (≡ tag) tags))
$ abort
$ mkAbortion' PreconditionFailed
$ "The entity tag doesn't match: " ⊕ cs value
abort $ mkAbortion' statusForNoneMatch
$ "The entity tag matches: *"
else
- case P.parseOnly (finishOff parser) (cs value) of
+ case P.parseOnly (finishOff def) (cs value) of
+ Right []
+ → abort $ mkAbortion' BadRequest
+ $ "Empty If-None-Match"
Right tags
- → when (any (≡ tag) (tags ∷ [ETag]))
+ → when (any (≡ tag) tags)
$ abort
$ mkAbortion' statusForNoneMatch
$ "The entity tag matches: " ⊕ cs value
+++ /dev/null
---- !ditz.rubyforge.org,2008-03-06/issue
-title: Introduce 'Parsable' type class
-desc: I'll send a pull request to bos/attoparsec when it's ready.
-type: :task
-component: Lucu
-release: Lucu-1.0
-reporter: PHO <pho@cielonegro.org>
-status: :closed
-disposition: :fixed
-creation_time: 2011-12-19 13:01:51.401625 Z
-references: []
-
-id: d23a51590bc111f85646532c9a8538dd04aa20b4
-log_events:
-- - 2011-12-19 13:01:52.375925 Z
- - PHO <pho@cielonegro.org>
- - created
- - ""
-- - 2011-12-19 13:02:07.064863 Z
- - 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