Destroy Data.Attoparsec.Parsable; use Data.Default instead

[Lucu.git] / Network / HTTP / Lucu / Resource.hs

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index a970b46f9f695595f435793768c2285b51221490..1abf14be8e6bc7782d47e97bb3ddda75128b8c3b 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE
     CPP
   , BangPatterns
+  , FlexibleContexts
   , GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings
@@ -147,8 +148,7 @@ import Control.Arrow
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Unicode
-import Data.Ascii (Ascii, CIAscii)
-import qualified Data.Ascii as A
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import Data.Attempt
 import qualified Data.Attoparsec.Char8 as P
 import Data.ByteString (ByteString)
@@ -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
@@ -165,7 +166,6 @@ import Data.Monoid.Unicode
 import Data.Proxy
 import Data.Tagged
 import Data.Text (Text)
-import qualified Data.Text as T
 import Data.Time
 import Data.Time.Format.HTTP
 import Network.HTTP.Lucu.Abortion
@@ -181,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)
@@ -266,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
@@ -294,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
@@ -318,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
@@ -332,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
 
@@ -395,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 で終了。
@@ -423,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
@@ -555,7 +559,7 @@ getChunks' limit = go limit (∅)
                     else
                         abort $ mkAbortion' RequestEntityTooLarge
                               $ "Request body must be smaller than "
-                              ⊕ T.pack (show limit)
+                              ⊕ cs (show limit)
                               ⊕ " bytes."
       go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
                     if Strict.null c then
@@ -613,7 +617,7 @@ getForm limit
                                                   $ "Malformed boundary: " ⊕ boundary
                        case parseMultipartFormData b src of
                          Right xs → return $ map (first cs) xs
-                         Left err → abort $ mkAbortion' BadRequest $ T.pack err
+                         Left err → abort $ mkAbortion' BadRequest $ cs err
 
 -- |@'redirect' code uri@ declares the response status as @code@ and
 -- \"Location\" header field as @uri@. The @code@ must satisfy
@@ -639,10 +643,10 @@ setContentType = setHeader "Content-Type" ∘ cs
 -- @uri@. You usually don't need to call this function directly.
 setLocation ∷ URI → Rsrc ()
 setLocation uri
-    = case A.fromChars uriStr of
-        Just a  → setHeader "Location" a
-        Nothing → abort $ mkAbortion' InternalServerError
-                        $ "Malformed URI: " ⊕ T.pack uriStr
+    = case ca uriStr of
+        Success a → setHeader "Location" a
+        Failure e → abort $ mkAbortion' InternalServerError
+                          $ cs (show e)
     where
       uriStr = uriToString id uri ""
 
@@ -657,12 +661,13 @@ setContentEncoding codings
                   _               → abort $ mkAbortion' InternalServerError
                                             "setContentEncoding: Unknown HTTP version"
          setHeader "Content-Encoding"
-             $ A.fromAsciiBuilder
+             $ cs
              $ mconcat
-             $ intersperse (A.toAsciiBuilder ", ")
+             $ intersperse (cs (", " ∷ Ascii))
              $ map tr codings
     where
-      toAB = A.toAsciiBuilder ∘ A.fromCIAscii
+      toAB ∷ ConvertSuccess α AsciiBuilder ⇒ α → AsciiBuilder
+      toAB = cs
 
 -- |@'setWWWAuthenticate' challenge@ declares the response header
 -- \"WWW-Authenticate\" as @challenge@.