Destroy Data.Attoparsec.Parsable; use Data.Default instead
authorPHO <pho@cielonegro.org>
Tue, 20 Dec 2011 12:50:46 +0000 (21:50 +0900)
committerPHO <pho@cielonegro.org>
Tue, 20 Dec 2011 12:50:46 +0000 (21:50 +0900)
16 files changed:
Data/Attoparsec/Parsable.hs [deleted file]
Lucu.cabal
Network/HTTP/Lucu/Authentication.hs
Network/HTTP/Lucu/Chunk.hs
Network/HTTP/Lucu/ContentCoding.hs
Network/HTTP/Lucu/ETag.hs
Network/HTTP/Lucu/Headers.hs
Network/HTTP/Lucu/HttpVersion.hs
Network/HTTP/Lucu/MIMEParams.hs
Network/HTTP/Lucu/MIMEType.hs
Network/HTTP/Lucu/MIMEType/Guess.hs
Network/HTTP/Lucu/MultipartForm.hs
Network/HTTP/Lucu/Request.hs
Network/HTTP/Lucu/RequestReader.hs
Network/HTTP/Lucu/Resource.hs
bugs/issue-d23a51590bc111f85646532c9a8538dd04aa20b4.yaml [deleted file]

diff --git a/Data/Attoparsec/Parsable.hs b/Data/Attoparsec/Parsable.hs
deleted file mode 100644 (file)
index d801fb7..0000000
+++ /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
index effcefd44304ba3cf398d75b24a5d3dd20ba43ac..d07f14f29f20df625c9c226d2a5b9b0f6ae29e37 100644 (file)
@@ -88,7 +88,6 @@ Library
             -DHAVE_SSL
 
     Exposed-Modules:
-        Data.Attoparsec.Parsable
         Data.Collections.Newtype.TH
         Network.HTTP.Lucu
         Network.HTTP.Lucu.Abortion
index c91aa7ea54dfae12364f2dde106aa4c3b4e89dca..a63419cea4b6b03e814120f82afeede81869d8cc 100644 (file)
@@ -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+/="
index 101ed7436c9b281db152af0ad542137335aef7c0..c2135ef1105ae96e85f0f39db1a32240b7ee5929 100644 (file)
@@ -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
index 033b48b4d941b6d462cfa4ebac231d0f3f1869d2..45a8b4e7dcd903deed0b9cecf92640c0b17ba7ff 100644 (file)
@@ -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 #-}
index b04912002be300ad01ad2b17b9a167caff195ebc..de7780c538992f696d1d7aa322685f2f8d13192f 100644 (file)
@@ -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
index e6641154adc1d390b1c7cd35bb4d5d5a4c71342d..5391743d1163833a1b47b8f10e14ef4edf91e369 100644 (file)
@@ -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 #-}
index 983cb503f09d0f85a670af16a387906f3c8d1a02..0a850c7aa1cc30f5005b122c2cd7567b8c4b87b9 100644 (file)
@@ -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))
index 37410330bd25fee7c589f5a1c3b7a234cbce0e18..e4e4271a6fcdd405b25804c113778f4158ae344a 100644 (file)
@@ -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) <$>
index 949bc44d2668219cef9b265eecc66b9eacae9774..768b4cf53d3227c1ff1fde966755acfa23eef780 100644 (file)
@@ -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.
 --
index 3149859026d9a28d3feeb99a2286961f1c74eca6..05d0cd606f383eccdbef688a39dfa4f1e215b3d5 100644 (file)
@@ -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)
index ecff350619b31c79c1e1b4ff1e960a3ed68cea9a..98699e43ca37d2e2a2978236130f50b6a705c04a 100644 (file)
@@ -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
index b6ffedbdb11ccf2ef0bfa2701998d0183e82c808..13ccf9c9420b8265fa244934ed2d98cebc1a497f 100644 (file)
@@ -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)
 
index 062ffe204ec192e5f5b0d0e52131f352989752d4..543c82e52e182524460a13d95efb09295fdd4578 100644 (file)
@@ -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
index 41415290961632701c97e8b9bb2c1639ba729e19..1abf14be8e6bc7782d47e97bb3ddda75128b8c3b 100644 (file)
@@ -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 (file)
index 3ff42d3..0000000
+++ /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 <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: