StatusCode is now a type class, not an algebraic data type.

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 71ff4838c3945380d44f2dee36fddc2b3952d3d1..f7b90f925447a774d303b90458487611837d6562 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -3,6 +3,7 @@
   , GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings
   , GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings

+  , QuasiQuotes

   , RecordWildCards
   , UnicodeSyntax
   #-}
   , 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
 --   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.
 --
 --   [/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 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 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
 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 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.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
 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.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.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)
 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
 -- |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)
 
 -- |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
 
 -- |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
 
 -- |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]
 --
 -- 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
 -- |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 ∘
 getQueryForm = parse' <$> getRequestURI
     where
       parse' = map toPairWithFormData ∘


@@ -230,13 +236,14 @@ getQueryForm = parse' <$> getRequestURI
                drop 1 ∘
                uriQuery
 
                drop 1 ∘
                uriQuery
 

-toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
+toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)

 toPairWithFormData (name, value)
     = let fd = FormData {
                  fdFileName = Nothing
 toPairWithFormData (name, value)
     = let fd = FormData {
                  fdFileName = Nothing

+               , fdMIMEType = [mimeType| text/plain |]

                , fdContent  = Lazy.fromChunks [value]
                }
                , 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
 
 -- |@'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
            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
                     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
 
 -- |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
                       -- 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
                        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)
 
       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)
 


@@ -315,14 +314,10 @@ getContentType
            Nothing
                → return Nothing
            Just cType
            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
                     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'.
 
 -- |Return the value of request header \"Authorization\" as
 -- 'AuthCredential'.


@@ -333,13 +328,9 @@ getAuthorization
            Nothing
                → return Nothing
            Just auth
            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
                     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
 
 -- |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
          -- 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
 
          let statusForNoneMatch
                  = if method ≡ GET ∨ method ≡ HEAD then

-                       NotModified
+                       fromStatusCode NotModified

                    else
                    else

-                       PreconditionFailed
+                       fromStatusCode PreconditionFailed

 
          -- If-None-Match があればそれを見る。
          ifNoneMatch ← getHeader "If-None-Match"
          case ifNoneMatch of
 
          -- 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
 
          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
 
 -- |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
 
          let statusForIfModSince
                  = if method ≡ GET ∨ method ≡ HEAD then

-                       NotModified
+                       fromStatusCode NotModified

                    else
                    else

-                       PreconditionFailed
+                       fromStatusCode PreconditionFailed

 
          -- If-Modified-Since があればそれを見る。
          ifModSince ← getHeader "If-Modified-Since"
 
          -- If-Modified-Since があればそれを見る。
          ifModSince ← getHeader "If-Modified-Since"


@@ -527,7 +518,6 @@ foundNoEntity' ∷ Resource ()
 {-# INLINE foundNoEntity' #-}
 foundNoEntity' = foundNoEntity Nothing
 
 {-# 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
 -- |@'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\".
 --
 -- 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
 getForm limit
     = do cTypeM ← getContentType
          case cTypeM of


@@ -598,7 +584,7 @@ getForm limit
                        $ A.toText
                        $ A.fromAsciiBuilder
                        $ A.toAsciiBuilder "Unsupported media type: "
                        $ A.toText
                        $ A.fromAsciiBuilder
                        $ A.toAsciiBuilder "Unsupported media type: "

-                       ⊕ printMIMEType cType
+                       ⊕ MT.printMIMEType cType

     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)


@@ -610,8 +596,8 @@ getForm limit
               Just a  → return a
               Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
 
               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
               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
                                 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' 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 "
              $ 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
          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
 -- 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.
 
 -- |@'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
 
 -- |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
 
 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
 -- 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
 putChunks ∷ Lazy.ByteString → Resource ()
 putChunks = putBuilder ∘ BB.fromLazyByteString