X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=f7b90f925447a774d303b90458487611837d6562;hp=71ff4838c3945380d44f2dee36fddc2b3952d3d1;hb=51eda5b;hpb=ece223c516e66223ef1d5d8e6bbe4054a235d983

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 71ff483..f7b90f9 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -3,6 +3,7 @@
   , GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings
+  , QuasiQuotes
   , RecordWildCards
   , UnicodeSyntax
   #-}
@@ -55,7 +56,7 @@
 --   automatically completes it depending on the status code. (To be
 --   exact, such completion only occurs when the 'Resource' transits
 --   to this state without even declaring the \"Content-Type\" header
---   field. See 'setContentType'.)
+--   field. See: 'setContentType')
 --
 --   [/Done/] Everything is over. A 'Resource' can do nothing for the
 --   HTTP interaction anymore.
@@ -141,13 +142,13 @@ import Blaze.ByteString.Builder (Builder)
 import qualified Blaze.ByteString.Builder as BB
 import qualified Blaze.ByteString.Builder.Internal as BB
 import Control.Applicative
+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 qualified Data.Attoparsec.Char8 as P
-import qualified Data.Attoparsec.Lazy  as LP
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
@@ -158,9 +159,9 @@ import Data.Monoid
 import Data.Monoid.Unicode
 import Data.Text (Text)
 import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
 import Data.Time
 import qualified Data.Time.HTTP as HTTP
+import Data.Typeable
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Authentication
 import Network.HTTP.Lucu.Config
@@ -170,10 +171,14 @@ import qualified Network.HTTP.Lucu.Headers as H
 import Network.HTTP.Lucu.HttpVersion
 import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.MultipartForm
+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)
@@ -182,15 +187,17 @@ import Prelude.Unicode
 -- |Get the string representation of the address of remote host. If
 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
 getRemoteAddr' ∷ Resource HostName
-getRemoteAddr'
-    = do sa ← getRemoteAddr
-         (fromJust ∘ fst) <$> (liftIO $ getNameInfo [NI_NUMERICHOST] True False sa)
+getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
+    where
+      toNM ∷ SockAddr → IO HostName
+      toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
 
 -- |Resolve an address to the remote host.
 getRemoteHost ∷ Resource (Maybe HostName)
-getRemoteHost
-    = do sa ← getRemoteAddr
-         fst <$> (liftIO $ getNameInfo [] True False sa)
+getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
+    where
+      getHN ∷ SockAddr → IO (Maybe HostName)
+      getHN = (fst <$>) ∘ getNameInfo [] True False
 
 -- |Get the 'Method' value of the request.
 getMethod ∷ Resource Method
@@ -206,8 +213,8 @@ getRequestVersion = reqVersion <$> getRequest
 
 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
 -- @[]@ if the corresponding
--- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
--- 'getResourcePath'.
+-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See:
+-- 'getResourcePath'
 --
 -- Note that the returned path components are URI-decoded.
 getPathInfo ∷ Resource [Strict.ByteString]
@@ -218,9 +225,8 @@ getPathInfo = do rsrcPath ← getResourcePath
 -- |Assume the query part of request URI as
 -- application\/x-www-form-urlencoded, and parse it into pairs of
 -- @(name, formData)@. This function doesn't read the request
--- body. Field names are decoded in UTF-8 for an hardly avoidable
--- reason. See 'getForm'.
-getQueryForm ∷ Resource [(Text, FormData)]
+-- body.
+getQueryForm ∷ Resource [(Strict.ByteString, FormData)]
 getQueryForm = parse' <$> getRequestURI
     where
       parse' = map toPairWithFormData ∘
@@ -230,13 +236,14 @@ getQueryForm = parse' <$> getRequestURI
                drop 1 ∘
                uriQuery
 
-toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
+toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)
 toPairWithFormData (name, value)
     = let fd = FormData {
                  fdFileName = Nothing
+               , fdMIMEType = [mimeType| text/plain |]
                , fdContent  = Lazy.fromChunks [value]
                }
-      in (T.decodeUtf8 name, fd)
+      in (name, fd)
 
 -- |@'getHeader' name@ returns the value of the request header field
 -- @name@. Comparison of header name is case-insensitive. Note that
@@ -255,14 +262,10 @@ getAccept
            Nothing
                → return []
            Just accept
-               → case P.parseOnly p (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
-    where
-      p = do xs ← mimeTypeListP
-             P.endOfInput
-             return xs
 
 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
 -- value of request header \"Accept-Encoding\". The list is sorted in
@@ -287,15 +290,11 @@ getAcceptEncoding
                       -- identity のみが許される。
                       return [("identity", Nothing)]
                  else
-                     case P.parseOnly p (A.toByteString ae) of
+                     case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of
                        Right xs → return $ map toTuple $ reverse $ sort xs
                        Left  _  → abort $ mkAbortion' BadRequest
                                         $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
     where
-      p = do xs ← acceptEncodingListP
-             P.endOfInput
-             return xs
-
       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)
 
@@ -315,14 +314,10 @@ getContentType
            Nothing
                → return Nothing
            Just cType
-               → case P.parseOnly p (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
-    where
-      p = do t ← mimeTypeP
-             P.endOfInput
-             return t
 
 -- |Return the value of request header \"Authorization\" as
 -- 'AuthCredential'.
@@ -333,13 +328,9 @@ getAuthorization
            Nothing
                → return Nothing
            Just auth
-               → case P.parseOnly p (A.toByteString auth) of
+               → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
                     Right ac → return $ Just ac
                     Left  _  → return Nothing
-    where
-      p = do ac ← authCredentialP
-             P.endOfInput
-             return ac
 
 -- |Tell the system that the 'Resource' found an entity for the
 -- request URI. If this is a GET or HEAD request, a found entity means
@@ -394,51 +385,51 @@ foundETag tag
          -- If-Match があればそれを見る。
          ifMatch ← getHeader "If-Match"
          case ifMatch of
-           Nothing    → return ()
-           Just value → if value ≡ "*" then
-                            return ()
-                        else
-                            case P.parseOnly p (A.toByteString value) of
-                              Right tags
-                                  -- tags の中に一致するものが無ければ
-                                  -- PreconditionFailed で終了。
-                                  → when ((¬) (any (≡ tag) tags))
-                                        $ abort
-                                        $ mkAbortion' PreconditionFailed
-                                        $ "The entity tag doesn't match: " ⊕ A.toText value
-                              Left _
-                                  → abort $ mkAbortion' BadRequest
-                                          $ "Unparsable If-Match: " ⊕ A.toText value
+           Nothing
+               → return ()
+           Just value
+               → if value ≡ "*" then
+                      return ()
+                  else
+                      case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+                        Right tags
+                            -- tags の中に一致するものが無ければ
+                            -- PreconditionFailed で終了。
+                            → when ((¬) (any (≡ tag) tags))
+                                  $ abort
+                                  $ mkAbortion' PreconditionFailed
+                                  $ "The entity tag doesn't match: " ⊕ A.toText value
+                        Left _
+                            → abort $ mkAbortion' BadRequest
+                                    $ "Unparsable If-Match: " ⊕ A.toText value
 
          let statusForNoneMatch
                  = if method ≡ GET ∨ method ≡ HEAD then
-                       NotModified
+                       fromStatusCode NotModified
                    else
-                       PreconditionFailed
+                       fromStatusCode PreconditionFailed
 
          -- If-None-Match があればそれを見る。
          ifNoneMatch ← getHeader "If-None-Match"
          case ifNoneMatch of
-           Nothing    → return ()
-           Just value → if value ≡ "*" then
-                            abort $ mkAbortion' statusForNoneMatch
-                                  $ "The entity tag matches: *"
-                        else
-                            case P.parseOnly p (A.toByteString value) of
-                              Right tags
-                                  → when (any (≡ tag) tags)
-                                        $ abort
-                                        $ mkAbortion' statusForNoneMatch
-                                        $ "The entity tag matches: " ⊕ A.toText value
-                              Left _
-                                  → abort $ mkAbortion' BadRequest
-                                          $ "Unparsable If-None-Match: " ⊕ A.toText value
+           Nothing
+               → return ()
+           Just value
+               → if value ≡ "*" then
+                      abort $ mkAbortion' statusForNoneMatch
+                            $ "The entity tag matches: *"
+                  else
+                      case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+                        Right tags
+                            → when (any (≡ tag) tags)
+                                  $ abort
+                                  $ mkAbortion' statusForNoneMatch
+                                  $ "The entity tag matches: " ⊕ A.toText value
+                        Left _
+                            → abort $ mkAbortion' BadRequest
+                                    $ "Unparsable If-None-Match: " ⊕ A.toText value
 
          driftTo ReceivingBody
-    where
-      p = do xs ← eTagListP
-             P.endOfInput
-             return xs
 
 -- |Tell the system that the 'Resource' found an entity for the
 -- request URI. The only difference from 'foundEntity' is that
@@ -464,9 +455,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"
@@ -527,7 +518,6 @@ foundNoEntity' ∷ Resource ()
 {-# INLINE foundNoEntity' #-}
 foundNoEntity' = foundNoEntity Nothing
 
-
 -- |@'getChunks' limit@ attemts to read the entire request body up to
 -- @limit@ bytes, and then make the 'Resource' transit to the
 -- /Deciding Header/ state. When the actual size of the body is larger
@@ -577,13 +567,9 @@ getChunks' limit = go limit (∅)
 -- Media Type\". If the request has no \"Content-Type\", it aborts
 -- with \"400 Bad Request\".
 --
--- Field names in @multipart\/form-data@ will be precisely decoded in
--- accordance with RFC 2231. On the other hand,
--- @application\/x-www-form-urlencoded@ says nothing about character
--- encodings for field names, so they'll always be decoded in
--- UTF-8. (This could be a bad design, but I can't think of any better
--- idea.)
-getForm ∷ Maybe Int → Resource [(Text, FormData)]
+-- Note that there are currently a few limitations on parsing
+-- @multipart/form-data@. See: 'parseMultipartFormData'
+getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)]
 getForm limit
     = do cTypeM ← getContentType
          case cTypeM of
@@ -598,7 +584,7 @@ getForm limit
                        $ A.toText
                        $ A.fromAsciiBuilder
                        $ A.toAsciiBuilder "Unsupported media type: "
-                       ⊕ printMIMEType cType
+                       ⊕ MT.printMIMEType cType
     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
@@ -610,8 +596,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
@@ -620,33 +606,23 @@ getForm limit
                                 Just b  → return b
                                 Nothing → abort $ mkAbortion' BadRequest
                                                 $ "Malformed boundary: " ⊕ boundary
-                       case LP.parse (p b) src of
-                         LP.Done _ formList
-                             → return formList
-                         LP.Fail _ eCtx e
-                             → abort $ mkAbortion' BadRequest
-                                     $ "Unparsable multipart/form-data: "
-                                     ⊕ T.pack (intercalate ", " eCtx)
-                                     ⊕ ": "
-                                     ⊕ T.pack e
-          where
-            p b = do xs ← multipartFormP b
-                     P.endOfInput
-                     return xs
+                       case parseMultipartFormData b src of
+                         Right xs → return $ map (first A.toByteString) xs
+                         Left err → abort $ mkAbortion' BadRequest $ T.pack err
 
 -- |@'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 (cast sc ≡ Just 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
@@ -654,7 +630,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.
@@ -692,7 +668,7 @@ setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
 
 -- |Write a chunk in 'Strict.ByteString' to the response body. You
 -- must first declare the response header \"Content-Type\" before
--- applying this function. See 'setContentType'.
+-- applying this function. See: 'setContentType'
 putChunk ∷ Strict.ByteString → Resource ()
 putChunk = putBuilder ∘ BB.fromByteString
 
@@ -700,7 +676,7 @@ putChunk = putBuilder ∘ BB.fromByteString
 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
 --
 -- Note that you must first declare the response header
--- \"Content-Type\" before applying this function. See
--- 'setContentType'.
+-- \"Content-Type\" before applying this function. See:
+-- 'setContentType'
 putChunks ∷ Lazy.ByteString → Resource ()
 putChunks = putBuilder ∘ BB.fromLazyByteString