X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=520502204df5d933484d85298115051574915dd3;hb=3b448555e621530c3483f03b4b5156dc606b2035;hp=19a2a0a73a4779e882b02114fcf28805a782eab8;hpb=1ead053df6a792edafa9d714c4c038a8a9c3ad16;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 19a2a0a..5205022 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,12 +1,14 @@
 {-# LANGUAGE
     CPP
   , BangPatterns
+  , FlexibleContexts
   , GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings
   , QuasiQuotes
   , RecordWildCards
   , UnicodeSyntax
+  , ViewPatterns
   #-}
 -- |This is the Resource Monad; monadic actions to define a behavior
 -- of resource. The 'Rsrc' Monad is a kind of 'IO' Monad thus it
@@ -71,7 +73,6 @@ module Network.HTTP.Lucu.Resource
     (
     -- * Types
       Resource(..)
-    , emptyResource
     , Rsrc
     , FormData(..)
 
@@ -148,21 +149,25 @@ 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)
 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.Default
 import Data.List (intersperse, sort)
 import Data.Maybe
 import Data.Monoid
 import Data.Monoid.Unicode
+import Data.Tagged
 import Data.Text (Text)
-import qualified Data.Text as T
 import Data.Time
-import qualified Data.Time.HTTP as HTTP
+import Data.Time.Format.HTTP
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Authentication
 import Network.HTTP.Lucu.Config
@@ -176,9 +181,8 @@ 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.Response.StatusCode
+import Network.HTTP.Lucu.MIMEType
 import Network.HTTP.Lucu.Utils
 import Network.Socket hiding (accept)
 import Network.URI hiding (path)
@@ -213,14 +217,13 @@ getRequestVersion ∷ Rsrc HttpVersion
 getRequestVersion = reqVersion <$> getRequest
 
 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
--- @[]@ if the corresponding
--- 'Network.HTTP.Lucu.Resource.Tree.Resource' is not greedy. See:
--- 'getResourcePath'
+-- @[]@ if the corresponding 'Resource' is not greedy. See
+-- 'getResourcePath'.
 --
 -- Note that the returned path components are URI-decoded.
 getPathInfo ∷ Rsrc [Strict.ByteString]
 getPathInfo = do rsrcPath ← getResourcePath
-                 reqPath  ← splitPathInfo <$> getRequestURI
+                 reqPath  ← uriPathSegments <$> getRequestURI
                  return $ drop (length rsrcPath) reqPath
 
 -- |Assume the query part of request URI as
@@ -232,8 +235,7 @@ getQueryForm = parse' <$> getRequestURI
     where
       parse' = map toPairWithFormData ∘
                parseWWWFormURLEncoded ∘
-               fromJust ∘
-               A.fromChars ∘
+               convertUnsafe ∘
                drop 1 ∘
                uriQuery
 
@@ -263,10 +265,10 @@ getAccept
            Nothing
                → return []
            Just accept
-               → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of
+               → case P.parseOnly (finishOff def) (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
@@ -291,10 +293,10 @@ getAcceptEncoding
                       -- identity のみが許される。
                       return [("identity", Nothing)]
                  else
-                     case P.parseOnly (finishOff acceptEncodingList) (A.toByteString 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: " ⊕ A.toText ae
+                                        $ "Unparsable Accept-Encoding: " ⊕ cs ae
     where
       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)
@@ -315,10 +317,10 @@ getContentType
            Nothing
                → return Nothing
            Just cType
-               → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of
+               → case P.parseOnly (finishOff def) (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'.
@@ -329,7 +331,7 @@ getAuthorization
            Nothing
                → return Nothing
            Just auth
-               → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
+               → case P.parseOnly (finishOff def) (cs auth) of
                     Right ac → return $ Just ac
                     Left  _  → return Nothing
 
@@ -353,7 +355,8 @@ foundEntity tag timeStamp
 
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
-             $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
+             $ setHeader "Last-Modified"
+             $ formatUTCTime timeStamp
          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError
@@ -375,8 +378,7 @@ foundETag tag
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "ETag"
-             $ A.fromAsciiBuilder
-             $ printETag tag
+             $ cs tag
          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError
@@ -391,17 +393,20 @@ foundETag tag
                → if value ≡ "*" then
                       return ()
                   else
-                      case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+                      case P.parseOnly (finishOff def) (cs value) of
+                        Right []
+                            → abort $ mkAbortion' BadRequest
+                                    $ "Empty If-Match"
                         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
@@ -419,15 +424,18 @@ foundETag tag
                       abort $ mkAbortion' statusForNoneMatch
                             $ "The entity tag matches: *"
                   else
-                      case P.parseOnly (finishOff eTagList) (A.toByteString 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
                                   $ 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
 
@@ -447,7 +455,8 @@ foundTimeStamp timeStamp
 
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
-             $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
+             $ setHeader "Last-Modified"
+             $ formatUTCTime timeStamp
          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError
@@ -461,31 +470,35 @@ foundTimeStamp timeStamp
 
          ifModSince ← getHeader "If-Modified-Since"
          case ifModSince of
-           Just str → case HTTP.fromAscii str of
-                         Right lastTime
+           Just str → case untag' <$> (fromAttempt $ ca str) of
+                         Just lastTime
                              → when (timeStamp ≤ lastTime)
                                $ abort
                                $ mkAbortion' statusForIfModSince
-                               $ "The entity has not been modified since " ⊕ A.toText str
-                         Left e
+                               $ "The entity has not been modified since " ⊕ cs str
+                         Nothing
                              → abort $ mkAbortion' BadRequest
-                                     $ "Malformed If-Modified-Since: " ⊕ T.pack e
+                                     $ "Malformed If-Modified-Since: " ⊕ cs str
            Nothing  → return ()
 
          ifUnmodSince ← getHeader "If-Unmodified-Since"
          case ifUnmodSince of
-           Just str → case HTTP.fromAscii str of
-                         Right lastTime
+           Just str → case untag' <$> (fromAttempt $ ca str) of
+                         Just lastTime
                              → when (timeStamp > lastTime)
                                $ abort
                                $ mkAbortion' PreconditionFailed
-                               $ "The entity has not been modified since " ⊕ A.toText str
-                         Left e
+                               $ "The entity has not been modified since " ⊕ cs str
+                         Nothing
                              → abort $ mkAbortion' BadRequest
-                                     $ "Malformed If-Unmodified-Since: " ⊕ T.pack e
+                                     $ "Malformed If-Unmodified-Since: " ⊕ cs str
            Nothing  → return ()
 
          driftTo ReceivingBody
+    where
+      untag' ∷ Tagged HTTP α → α
+      {-# INLINE untag' #-}
+      untag' = untag
 
 -- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' found no
 -- entity for the request URI. @mStr@ is an optional error message to
@@ -549,7 +562,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
@@ -581,10 +594,9 @@ getForm limit
                → readMultipartFormData params
            Just cType
                → abort $ mkAbortion' UnsupportedMediaType
-                       $ A.toText
-                       $ A.fromAsciiBuilder
-                       $ A.toAsciiBuilder "Unsupported media type: "
-                       ⊕ MT.printMIMEType cType
+                       $ cs
+                       $ ("Unsupported media type: " ∷ Ascii)
+                       ⊕ cs cType
     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
@@ -592,9 +604,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
@@ -602,26 +614,25 @@ 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
-                         Left err → abort $ mkAbortion' BadRequest $ T.pack err
+                         Right xs → return $ map (first cs) xs
+                         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
 -- 'isRedirection' or it raises an error.
 redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc ()
-redirect sc uri
-    = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
+redirect (fromStatusCode → sc) uri
+    = do when (sc ≡ cs 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 sc
          setStatus sc
          setLocation uri
 
@@ -629,17 +640,16 @@ redirect sc uri
 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
 -- mandatory for sending a response body.
 setContentType ∷ MIMEType → Rsrc ()
-setContentType
-    = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType
+setContentType = setHeader "Content-Type" ∘ cs
 
 -- |@'setLocation' uri@ declares the response header \"Location\" as
 -- @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 ""
 
@@ -654,21 +664,22 @@ 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@.
 setWWWAuthenticate ∷ AuthChallenge → Rsrc ()
-setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
+setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ cs
 
 -- |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 → Rsrc ()
 putChunk = putBuilder ∘ BB.fromByteString
 
@@ -676,7 +687,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 → Rsrc ()
 putChunks = putBuilder ∘ BB.fromLazyByteString