X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=97b2cbe3cb491c4b64853fe6a60bfab0895ca171;hp=474f79adca923a7781d3d40535d047807cc85f33;hb=3318fe0;hpb=e49345ce5e6c0190c826d130d51ec42ee9f09a67

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 474f79a..97b2cbe 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -3,6 +3,7 @@
   , GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings
+  , QuasiQuotes
   , RecordWildCards
   , UnicodeSyntax
   #-}
@@ -173,7 +174,10 @@ 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
+import Network.HTTP.Lucu.MIMEParams
+import Network.HTTP.Lucu.MIMEType (MIMEType(..))
+import qualified Network.HTTP.Lucu.MIMEType as MT
+import Network.HTTP.Lucu.MIMEType.TH
 import Network.HTTP.Lucu.Utils
 import Network.Socket hiding (accept)
 import Network.URI hiding (path)
@@ -235,7 +239,7 @@ toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData
 toPairWithFormData (name, value)
     = let fd = FormData {
                  fdFileName = Nothing
-               , fdMIMEType = parseMIMEType "text/plain"
+               , fdMIMEType = [mimeType| text/plain |]
                , fdContent  = Lazy.fromChunks [value]
                }
       in (name, fd)
@@ -257,7 +261,7 @@ getAccept
            Nothing
                → return []
            Just accept
-               → case P.parseOnly (finishOff mimeTypeList) (A.toByteString accept) of
+               → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of
                     Right xs → return xs
                     Left  _  → abort $ mkAbortion' BadRequest
                                      $ "Unparsable Accept: " ⊕ A.toText accept
@@ -309,7 +313,7 @@ getContentType
            Nothing
                → return Nothing
            Just cType
-               → case P.parseOnly (finishOff mimeType) (A.toByteString cType) of
+               → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of
                     Right t → return $ Just t
                     Left  _ → abort $ mkAbortion' BadRequest
                                     $ "Unparsable Content-Type: " ⊕ A.toText cType
@@ -400,9 +404,9 @@ foundETag tag
 
          let statusForNoneMatch
                  = if method ≡ GET ∨ method ≡ HEAD then
-                       NotModified
+                       fromStatusCode NotModified
                    else
-                       PreconditionFailed
+                       fromStatusCode PreconditionFailed
 
          -- If-None-Match があればそれを見る。
          ifNoneMatch ← getHeader "If-None-Match"
@@ -450,9 +454,9 @@ foundTimeStamp timeStamp
 
          let statusForIfModSince
                  = if method ≡ GET ∨ method ≡ HEAD then
-                       NotModified
+                       fromStatusCode NotModified
                    else
-                       PreconditionFailed
+                       fromStatusCode PreconditionFailed
 
          -- If-Modified-Since があればそれを見る。
          ifModSince ← getHeader "If-Modified-Since"
@@ -579,7 +583,7 @@ getForm limit
                        $ A.toText
                        $ A.fromAsciiBuilder
                        $ A.toAsciiBuilder "Unsupported media type: "
-                       ⊕ printMIMEType cType
+                       ⊕ MT.printMIMEType cType
     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
@@ -591,8 +595,8 @@ getForm limit
               Just a  → return a
               Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
 
-      readMultipartFormData params
-          = case M.lookup "boundary" params of
+      readMultipartFormData (MIMEParams m)
+          = case M.lookup "boundary" m of
               Nothing
                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
               Just boundary
@@ -608,16 +612,16 @@ getForm limit
 -- |@'redirect' code uri@ declares the response status as @code@ and
 -- \"Location\" header field as @uri@. The @code@ must satisfy
 -- 'isRedirection' or it raises an error.
-redirect ∷ StatusCode → URI → Resource ()
-redirect code uri
-    = do when (code ≡ NotModified ∨ not (isRedirection code))
+redirect ∷ StatusCode sc ⇒ sc → URI → Resource ()
+redirect sc uri
+    = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
              $ abort
              $ mkAbortion' InternalServerError
              $ A.toText
              $ A.fromAsciiBuilder
              $ A.toAsciiBuilder "Attempted to redirect with status "
-             ⊕ printStatusCode code
-         setStatus code
+             ⊕ printStatusCode sc
+         setStatus sc
          setLocation uri
 
 -- |@'setContentType' mType@ declares the response header
@@ -625,7 +629,7 @@ redirect code uri
 -- mandatory for sending a response body.
 setContentType ∷ MIMEType → Resource ()
 setContentType
-    = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
+    = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType
 
 -- |@'setLocation' uri@ declares the response header \"Location\" as
 -- @uri@. You usually don't need to call this function directly.