From 90fca0675b1694e69b8e431c989343855cbd125d Mon Sep 17 00:00:00 2001 From: PHO Date: Tue, 20 Dec 2011 21:50:46 +0900 Subject: [PATCH] Destroy Data.Attoparsec.Parsable; use Data.Default instead --- Data/Attoparsec/Parsable.hs | 65 ------------------- Lucu.cabal | 1 - Network/HTTP/Lucu/Authentication.hs | 28 ++++---- Network/HTTP/Lucu/Chunk.hs | 6 +- Network/HTTP/Lucu/ContentCoding.hs | 26 ++++---- Network/HTTP/Lucu/ETag.hs | 24 +++---- Network/HTTP/Lucu/Headers.hs | 13 ++-- Network/HTTP/Lucu/HttpVersion.hs | 14 ++-- Network/HTTP/Lucu/MIMEParams.hs | 41 ++++++------ Network/HTTP/Lucu/MIMEType.hs | 26 ++++---- Network/HTTP/Lucu/MIMEType/Guess.hs | 4 +- Network/HTTP/Lucu/MultipartForm.hs | 10 +-- Network/HTTP/Lucu/Request.hs | 31 ++++----- Network/HTTP/Lucu/RequestReader.hs | 16 ++--- Network/HTTP/Lucu/Resource.hs | 24 ++++--- ...a51590bc111f85646532c9a8538dd04aa20b4.yaml | 27 -------- 16 files changed, 134 insertions(+), 222 deletions(-) delete mode 100644 Data/Attoparsec/Parsable.hs delete mode 100644 bugs/issue-d23a51590bc111f85646532c9a8538dd04aa20b4.yaml diff --git a/Data/Attoparsec/Parsable.hs b/Data/Attoparsec/Parsable.hs deleted file mode 100644 index d801fb7..0000000 --- a/Data/Attoparsec/Parsable.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# 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 diff --git a/Lucu.cabal b/Lucu.cabal index effcefd..d07f14f 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -88,7 +88,6 @@ Library -DHAVE_SSL Exposed-Modules: - Data.Attoparsec.Parsable Data.Collections.Newtype.TH Network.HTTP.Lucu Network.HTTP.Lucu.Abortion diff --git a/Network/HTTP/Lucu/Authentication.hs b/Network/HTTP/Lucu/Authentication.hs index c91aa7e..a63419c 100644 --- a/Network/HTTP/Lucu/Authentication.hs +++ b/Network/HTTP/Lucu/Authentication.hs @@ -3,6 +3,7 @@ , MultiParamTypeClasses , OverloadedStrings , TemplateHaskell + , TypeSynonymInstances , UnicodeSyntax #-} -- |An internal module for HTTP authentication. @@ -18,13 +19,12 @@ 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 () import Data.Convertible.Utils +import Data.Default import Data.Monoid.Unicode import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils @@ -65,18 +65,18 @@ deriveAttempts [ ([t| AuthChallenge |], [t| Ascii |]) , ([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+/=" diff --git a/Network/HTTP/Lucu/Chunk.hs b/Network/HTTP/Lucu/Chunk.hs index 101ed74..c2135ef 100644 --- a/Network/HTTP/Lucu/Chunk.hs +++ b/Network/HTTP/Lucu/Chunk.hs @@ -9,8 +9,8 @@ module Network.HTTP.Lucu.Chunk 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 @@ -29,7 +29,9 @@ chunkHeader = do len ← hexadecimal (token <|> quotedStr) ) chunkFooter ∷ Parser () +{-# INLINE chunkFooter #-} chunkFooter = crlf chunkTrailer ∷ Parser Headers -chunkTrailer = parser +{-# INLINE chunkTrailer #-} +chunkTrailer = def diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs index 033b48b..45a8b4e 100644 --- a/Network/HTTP/Lucu/ContentCoding.hs +++ b/Network/HTTP/Lucu/ContentCoding.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances , MultiParamTypeClasses + , TypeSynonymInstances , OverloadedStrings , UnicodeSyntax #-} @@ -13,8 +14,7 @@ module Network.HTTP.Lucu.ContentCoding 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 @@ -36,18 +36,18 @@ instance Ord AcceptEncoding where 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 #-} diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs index b049120..de7780c 100644 --- a/Network/HTTP/Lucu/ETag.hs +++ b/Network/HTTP/Lucu/ETag.hs @@ -5,6 +5,7 @@ , OverloadedStrings , RecordWildCards , TemplateHaskell + , TypeSynonymInstances , UnicodeSyntax #-} -- |An internal module for entity tags. @@ -15,15 +16,13 @@ module Network.HTTP.Lucu.ETag ) 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 () @@ -81,15 +80,12 @@ weakETag ∷ Ascii → ETag {-# 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 diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index e664115..5391743 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -20,12 +20,11 @@ import Control.Monad 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 @@ -139,11 +138,11 @@ deriveAttempts [ ([t| Headers |], [t| Ascii |]) 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 #-} diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs index 983cb50..0a850c7 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -3,6 +3,7 @@ , MultiParamTypeClasses , OverloadedStrings , TemplateHaskell + , TypeSynonymInstances , UnicodeSyntax #-} -- |An internal module for HTTP version numbers. @@ -14,11 +15,10 @@ 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 +import Data.Default import Data.Monoid.Unicode import Prelude hiding (min) import Prelude.Unicode @@ -58,8 +58,8 @@ deriveAttempts [ ([t| HttpVersion |], [t| Ascii |]) , ([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)) diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs index 3741033..e4e4271 100644 --- a/Network/HTTP/Lucu/MIMEParams.hs +++ b/Network/HTTP/Lucu/MIMEParams.hs @@ -24,9 +24,7 @@ import Control.Monad.Unicode 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 @@ -35,6 +33,7 @@ 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 qualified Data.Map as M (Map) import Data.Monoid.Unicode import Data.Sequence (Seq) @@ -146,26 +145,26 @@ section ∷ ExtendedParam → Integer 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) <$> diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index 949bc44..768b4cf 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -5,6 +5,7 @@ , OverloadedStrings , RecordWildCards , TemplateHaskell + , TypeSynonymInstances , UnicodeSyntax , ViewPatterns #-} @@ -20,11 +21,10 @@ 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.Default import Data.Monoid.Unicode import Data.Typeable import Language.Haskell.TH.Syntax @@ -75,21 +75,21 @@ deriveAttempts [ ([t| MIMEType |], [t| Ascii |]) 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. -- diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 3149859..05d0cd6 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -19,10 +19,10 @@ module Network.HTTP.Lucu.MIMEType.Guess 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 @@ -99,7 +99,7 @@ instance ConvertAttempt Lazy.ByteString ExtMap where pair ∷ Parser (MIMEType, [Text]) pair = do skipSpace - mime ← parser + mime ← def skipSpace1 exts ← sepBy1 ext $ skipWhile1 (≡ '\x20') return (mime, exts) diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index ecff350..98699e4 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -26,7 +26,6 @@ import Data.Ascii (Ascii, CIAscii, AsciiBuilder) 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 @@ -34,6 +33,7 @@ import Data.Collections 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 @@ -169,7 +169,8 @@ parsePart boundary src defaultCType = [mimeType| text/plain |] partHeader ∷ Parser Headers -partHeader = crlf *> parser +{-# INLINE partHeader #-} +partHeader = crlf *> def getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo {-# INLINEABLE getContDispo #-} @@ -186,8 +187,9 @@ getContDispo hdrs ⊕ err contentDisposition ∷ Parser ContDispo +{-# INLINEABLE contentDisposition #-} contentDisposition - = (ContDispo <$> (cs <$> token) ⊛ parser) + = (ContDispo <$> (cs <$> token) ⊛ def) "contentDisposition" @@ -198,7 +200,7 @@ getContType hdrs 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 diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs index b6ffedb..13ccf9c 100644 --- a/Network/HTTP/Lucu/Request.hs +++ b/Network/HTTP/Lucu/Request.hs @@ -1,6 +1,8 @@ {-# LANGUAGE - MultiParamTypeClasses + FlexibleInstances + , MultiParamTypeClasses , OverloadedStrings + , TypeSynonymInstances , UnicodeSyntax , ViewPatterns #-} @@ -17,9 +19,8 @@ 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 Data.Default import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Parser.Http @@ -63,17 +64,17 @@ reqHasBody (reqMethod → m) | 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 #-} @@ -81,7 +82,7 @@ requestLine = do meth ← method sp u ← uri sp - ver ← parser + ver ← def crlf return (meth, u, ver) diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 062ffe2..543c82e 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -16,11 +16,11 @@ import Control.Exception hiding (block) 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 @@ -95,7 +95,7 @@ acceptRequest ctx@(Context {..}) input 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 @@ -114,15 +114,15 @@ acceptParsableRequest ctx@(Context {..}) req input 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 @@ -141,7 +141,7 @@ acceptRequestForResource ∷ HandleLike 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 @@ -149,7 +149,7 @@ acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsr #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 diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 4141529..1abf14b 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -151,7 +151,6 @@ import Control.Monad.Unicode 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 @@ -159,6 +158,7 @@ import Data.Collections 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 @@ -264,7 +264,7 @@ getAccept 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 @@ -292,7 +292,7 @@ getAcceptEncoding -- 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 @@ -316,7 +316,7 @@ getContentType 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 @@ -330,7 +330,7 @@ getAuthorization 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 @@ -393,11 +393,14 @@ foundETag tag → 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 @@ -421,9 +424,12 @@ foundETag tag 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 diff --git a/bugs/issue-d23a51590bc111f85646532c9a8538dd04aa20b4.yaml b/bugs/issue-d23a51590bc111f85646532c9a8538dd04aa20b4.yaml deleted file mode 100644 index 3ff42d3..0000000 --- a/bugs/issue-d23a51590bc111f85646532c9a8538dd04aa20b4.yaml +++ /dev/null @@ -1,27 +0,0 @@ ---- !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 -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 - - created - - "" -- - 2011-12-19 13:02:07.064863 Z - - PHO - - changed status from unstarted to in_progress - - "" -- - 2011-12-19 14:29:32.083785 Z - - PHO - - closed with disposition fixed - - Done. -git_branch: -- 2.40.0