X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=1abf14be8e6bc7782d47e97bb3ddda75128b8c3b;hp=8585ceaf29ce993f6a1a002ed41c61d3f5c18f1e;hb=90fca0675b1694e69b8e431c989343855cbd125d;hpb=c9a269666f2d60d9c5ba817e1c43b45f6d77de22

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 8585cea..1abf14b 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -158,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
@@ -180,9 +181,7 @@ import Network.HTTP.Lucu.Parser
 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)
@@ -265,7 +264,7 @@ getAccept
            Nothing
                → return []
            Just accept
-               → case P.parseOnly (finishOff MT.mimeTypeList) (cs accept) of
+               → case P.parseOnly (finishOff def) (cs accept) of
                     Right xs → return xs
                     Left  _  → abort $ mkAbortion' BadRequest
                                      $ "Unparsable Accept: " ⊕ cs accept
@@ -293,7 +292,7 @@ getAcceptEncoding
                       -- identity のみが許される。
                       return [("identity", Nothing)]
                  else
-                     case P.parseOnly (finishOff acceptEncodingList) (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
@@ -317,7 +316,7 @@ getContentType
            Nothing
                → return Nothing
            Just cType
-               → case P.parseOnly (finishOff MT.mimeType) (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
@@ -331,7 +330,7 @@ getAuthorization
            Nothing
                → return Nothing
            Just auth
-               → case P.parseOnly (finishOff authCredential) (cs auth) of
+               → case P.parseOnly (finishOff def) (cs auth) of
                     Right ac → return $ Just ac
                     Left  _  → return Nothing
 
@@ -394,7 +393,10 @@ foundETag tag
                → if value ≡ "*" then
                       return ()
                   else
-                      case P.parseOnly (finishOff eTagList) (cs value) of
+                      case P.parseOnly (finishOff def) (cs value) of
+                        Right []
+                            → abort $ mkAbortion' BadRequest
+                                    $ "Empty If-Match"
                         Right tags
                             -- tags の中に一致するものが無ければ
                             -- PreconditionFailed で終了。
@@ -422,7 +424,10 @@ foundETag tag
                       abort $ mkAbortion' statusForNoneMatch
                             $ "The entity tag matches: *"
                   else
-                      case P.parseOnly (finishOff eTagList) (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)
                                   $ abort