X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;fp=Network%2FHTTP%2FLucu%2FResource.hs;h=a970b46f9f695595f435793768c2285b51221490;hp=b478503c8bc53d6af8b74e6b9cf196350b1772c2;hb=bb41be0c967538a1014c87103a3a5d3840ad3e15;hpb=0678be80d2cab7c670aba82659bde87ba84b926b

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index b478503..a970b46 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -156,6 +156,8 @@ import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import Data.Collections
 import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
+import Data.Convertible.Utils
 import Data.List (intersperse, sort)
 import Data.Maybe
 import Data.Monoid
@@ -234,8 +236,7 @@ getQueryForm = parse' <$> getRequestURI
     where
       parse' = map toPairWithFormData ∘
                parseWWWFormURLEncoded ∘
-               fromJust ∘
-               A.fromChars ∘
+               convertUnsafe ∘
                drop 1 ∘
                uriQuery
 
@@ -265,10 +266,10 @@ getAccept
            Nothing
                → return []
            Just accept
-               → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of
+               → case P.parseOnly (finishOff MT.mimeTypeList) (cs accept) of
                     Right xs → return xs
                     Left  _  → abort $ mkAbortion' BadRequest
-                                     $ "Unparsable Accept: " ⊕ A.toText accept
+                                     $ "Unparsable Accept: " ⊕ cs accept
 
 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
 -- value of request header \"Accept-Encoding\". The list is sorted in
@@ -293,10 +294,10 @@ getAcceptEncoding
                       -- identity のみが許される。
                       return [("identity", Nothing)]
                  else
-                     case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of
+                     case P.parseOnly (finishOff acceptEncodingList) (cs ae) of
                        Right xs → return $ map toTuple $ reverse $ sort xs
                        Left  _  → abort $ mkAbortion' BadRequest
-                                        $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
+                                        $ "Unparsable Accept-Encoding: " ⊕ cs ae
     where
       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)
@@ -317,10 +318,10 @@ getContentType
            Nothing
                → return Nothing
            Just cType
-               → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of
+               → case P.parseOnly (finishOff MT.mimeType) (cs cType) of
                     Right t → return $ Just t
                     Left  _ → abort $ mkAbortion' BadRequest
-                                    $ "Unparsable Content-Type: " ⊕ A.toText cType
+                                    $ "Unparsable Content-Type: " ⊕ cs cType
 
 -- |Return the value of request header \"Authorization\" as
 -- 'AuthCredential'.
@@ -331,7 +332,7 @@ getAuthorization
            Nothing
                → return Nothing
            Just auth
-               → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
+               → case P.parseOnly (finishOff authCredential) (cs auth) of
                     Right ac → return $ Just ac
                     Left  _  → return Nothing
 
@@ -379,7 +380,6 @@ foundETag tag
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "ETag"
-             $ A.fromAsciiBuilder
              $ cs tag
          when (method ≡ POST)
              $ abort
@@ -395,17 +395,17 @@ foundETag tag
                → if value ≡ "*" then
                       return ()
                   else
-                      case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+                      case P.parseOnly (finishOff eTagList) (cs value) of
                         Right tags
                             -- tags の中に一致するものが無ければ
                             -- PreconditionFailed で終了。
                             → when ((¬) (any (≡ tag) tags))
                                   $ abort
                                   $ mkAbortion' PreconditionFailed
-                                  $ "The entity tag doesn't match: " ⊕ A.toText value
+                                  $ "The entity tag doesn't match: " ⊕ cs value
                         Left _
                             → abort $ mkAbortion' BadRequest
-                                    $ "Unparsable If-Match: " ⊕ A.toText value
+                                    $ "Unparsable If-Match: " ⊕ cs value
 
          let statusForNoneMatch
                  = if method ≡ GET ∨ method ≡ HEAD then
@@ -423,15 +423,15 @@ foundETag tag
                       abort $ mkAbortion' statusForNoneMatch
                             $ "The entity tag matches: *"
                   else
-                      case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+                      case P.parseOnly (finishOff eTagList) (cs value) of
                         Right tags
                             → when (any (≡ tag) tags)
                                   $ abort
                                   $ mkAbortion' statusForNoneMatch
-                                  $ "The entity tag matches: " ⊕ A.toText value
+                                  $ "The entity tag matches: " ⊕ cs value
                         Left _
                             → abort $ mkAbortion' BadRequest
-                                    $ "Unparsable If-None-Match: " ⊕ A.toText value
+                                    $ "Unparsable If-None-Match: " ⊕ cs value
 
          driftTo ReceivingBody
 
@@ -472,10 +472,10 @@ foundTimeStamp timeStamp
                              → when (timeStamp ≤ lastTime)
                                $ abort
                                $ mkAbortion' statusForIfModSince
-                               $ "The entity has not been modified since " ⊕ A.toText str
+                               $ "The entity has not been modified since " ⊕ cs str
                          Nothing
                              → abort $ mkAbortion' BadRequest
-                                     $ "Malformed If-Modified-Since: " ⊕ A.toText str
+                                     $ "Malformed If-Modified-Since: " ⊕ cs str
            Nothing  → return ()
 
          ifUnmodSince ← getHeader "If-Unmodified-Since"
@@ -485,10 +485,10 @@ foundTimeStamp timeStamp
                              → when (timeStamp > lastTime)
                                $ abort
                                $ mkAbortion' PreconditionFailed
-                               $ "The entity has not been modified since " ⊕ A.toText str
+                               $ "The entity has not been modified since " ⊕ cs str
                          Nothing
                              → abort $ mkAbortion' BadRequest
-                                     $ "Malformed If-Unmodified-Since: " ⊕ A.toText str
+                                     $ "Malformed If-Unmodified-Since: " ⊕ cs str
            Nothing  → return ()
 
          driftTo ReceivingBody
@@ -597,9 +597,9 @@ getForm limit
             (bsToAscii =≪ getChunks limit)
 
       bsToAscii bs
-          = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
-              Just a  → return a
-              Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
+          = case convertAttemptVia ((⊥) ∷ ByteString) bs of
+              Success a → return a
+              Failure e → abort $ mkAbortion' BadRequest $ cs (show e)
 
       readMultipartFormData m
           = case lookup "boundary" m of
@@ -607,12 +607,12 @@ getForm limit
                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
               Just boundary
                   → do src ← getChunks limit
-                       b   ← case A.fromText boundary of
-                                Just b  → return b
-                                Nothing → abort $ mkAbortion' BadRequest
-                                                $ "Malformed boundary: " ⊕ boundary
+                       b   ← case ca boundary of
+                                Success b → return b
+                                Failure _ → abort $ mkAbortion' BadRequest
+                                                  $ "Malformed boundary: " ⊕ boundary
                        case parseMultipartFormData b src of
-                         Right xs → return $ map (first A.toByteString) xs
+                         Right xs → return $ map (first cs) xs
                          Left err → abort $ mkAbortion' BadRequest $ T.pack err
 
 -- |@'redirect' code uri@ declares the response status as @code@ and
@@ -623,10 +623,9 @@ redirect sc uri
     = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
              $ abort
              $ mkAbortion' InternalServerError
-             $ A.toText
-             $ A.fromAsciiBuilder
-             $ A.toAsciiBuilder "Attempted to redirect with status "
-             ⊕ printStatusCode sc
+             $ cs
+             $ ("Attempted to redirect with status " ∷ Ascii)
+             ⊕ cs (fromStatusCode sc)
          setStatus sc
          setLocation uri