Merge branch 'parsable'

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 6f3ecce8b851e8526e1f5eb48f6bf255656533ab..41415290961632701c97e8b9bb2c1639ba729e19 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE
     CPP
   , BangPatterns
 {-# LANGUAGE
     CPP
   , BangPatterns

+  , FlexibleContexts

   , GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings
   , GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings


@@ -147,15 +148,17 @@ import Control.Arrow
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Unicode
 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.Attempt
 import qualified Data.Attoparsec.Char8 as P

+import Data.Attoparsec.Parsable

 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.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.List (intersperse, sort)
 import Data.Maybe
 import Data.Monoid
 import Data.List (intersperse, sort)
 import Data.Maybe
 import Data.Monoid


@@ -163,7 +166,6 @@ import Data.Monoid.Unicode
 import Data.Proxy
 import Data.Tagged
 import Data.Text (Text)
 import Data.Proxy
 import Data.Tagged
 import Data.Text (Text)

-import qualified Data.Text as T

 import Data.Time
 import Data.Time.Format.HTTP
 import Network.HTTP.Lucu.Abortion
 import Data.Time
 import Data.Time.Format.HTTP
 import Network.HTTP.Lucu.Abortion


@@ -179,9 +181,7 @@ 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 (MIMEType(..))
-import qualified Network.HTTP.Lucu.MIMEType as MT
-import Network.HTTP.Lucu.MIMEType.TH
+import Network.HTTP.Lucu.MIMEType

 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)


@@ -234,8 +234,7 @@ getQueryForm = parse' <$> getRequestURI
     where
       parse' = map toPairWithFormData ∘
                parseWWWFormURLEncoded ∘
     where
       parse' = map toPairWithFormData ∘
                parseWWWFormURLEncoded ∘

-               fromJust ∘
-               A.fromChars ∘
+               convertUnsafe ∘

                drop 1 ∘
                uriQuery
 
                drop 1 ∘
                uriQuery
 


@@ -265,10 +264,10 @@ getAccept
            Nothing
                → return []
            Just accept
            Nothing
                → return []
            Just accept

-               → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of
+               → case P.parseOnly (finishOff parser) (cs accept) of

                     Right xs → return xs
                     Left  _  → abort $ mkAbortion' BadRequest
                     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
 
 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
 -- value of request header \"Accept-Encoding\". The list is sorted in


@@ -293,10 +292,10 @@ getAcceptEncoding
                       -- identity のみが許される。
                       return [("identity", Nothing)]
                  else
                       -- identity のみが許される。
                       return [("identity", Nothing)]
                  else

-                     case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of
+                     case P.parseOnly (finishOff parser) (cs ae) of

                        Right xs → return $ map toTuple $ reverse $ sort xs
                        Left  _  → abort $ mkAbortion' BadRequest
                        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)
     where
       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)


@@ -317,10 +316,10 @@ getContentType
            Nothing
                → return Nothing
            Just cType
            Nothing
                → return Nothing
            Just cType

-               → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of
+               → case P.parseOnly (finishOff parser) (cs cType) of

                     Right t → return $ Just t
                     Left  _ → abort $ mkAbortion' BadRequest
                     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'.
 
 -- |Return the value of request header \"Authorization\" as
 -- 'AuthCredential'.


@@ -331,7 +330,7 @@ getAuthorization
            Nothing
                → return Nothing
            Just auth
            Nothing
                → return Nothing
            Just auth

-               → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
+               → case P.parseOnly (finishOff parser) (cs auth) of

                     Right ac → return $ Just ac
                     Left  _  → return Nothing
 
                     Right ac → return $ Just ac
                     Left  _  → return Nothing
 


@@ -379,7 +378,6 @@ foundETag tag
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "ETag"
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "ETag"

-             $ A.fromAsciiBuilder

              $ cs tag
          when (method ≡ POST)
              $ abort
              $ cs tag
          when (method ≡ POST)
              $ abort


@@ -395,17 +393,17 @@ foundETag tag
                → if value ≡ "*" then
                       return ()
                   else
                → if value ≡ "*" then
                       return ()
                   else

-                      case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+                      case P.parseOnly (finishOff parser) (cs value) of

                         Right tags
                             -- tags の中に一致するものが無ければ
                             -- PreconditionFailed で終了。
                         Right tags
                             -- tags の中に一致するものが無ければ
                             -- PreconditionFailed で終了。

-                            → when ((¬) (any (≡ tag) tags))
+                            → when ((¬) (any (≡ tag) (tags ∷ [ETag])))

                                   $ abort
                                   $ mkAbortion' PreconditionFailed
                                   $ abort
                                   $ mkAbortion' PreconditionFailed

-                                  $ "The entity tag doesn't match: " ⊕ A.toText value
+                                  $ "The entity tag doesn't match: " ⊕ cs value

                         Left _
                             → abort $ mkAbortion' BadRequest
                         Left _
                             → abort $ mkAbortion' BadRequest

-                                    $ "Unparsable If-Match: " ⊕ A.toText value
+                                    $ "Unparsable If-Match: " ⊕ cs value

 
          let statusForNoneMatch
                  = if method ≡ GET ∨ method ≡ HEAD then
 
          let statusForNoneMatch
                  = if method ≡ GET ∨ method ≡ HEAD then


@@ -423,15 +421,15 @@ foundETag tag
                       abort $ mkAbortion' statusForNoneMatch
                             $ "The entity tag matches: *"
                   else
                       abort $ mkAbortion' statusForNoneMatch
                             $ "The entity tag matches: *"
                   else

-                      case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+                      case P.parseOnly (finishOff parser) (cs value) of

                         Right tags
                         Right tags

-                            → when (any (≡ tag) tags)
+                            → when (any (≡ tag) (tags ∷ [ETag]))

                                   $ abort
                                   $ mkAbortion' statusForNoneMatch
                                   $ abort
                                   $ mkAbortion' statusForNoneMatch

-                                  $ "The entity tag matches: " ⊕ A.toText value
+                                  $ "The entity tag matches: " ⊕ cs value

                         Left _
                             → abort $ mkAbortion' BadRequest
                         Left _
                             → abort $ mkAbortion' BadRequest

-                                    $ "Unparsable If-None-Match: " ⊕ A.toText value
+                                    $ "Unparsable If-None-Match: " ⊕ cs value

 
          driftTo ReceivingBody
 
 
          driftTo ReceivingBody
 


@@ -472,10 +470,10 @@ foundTimeStamp timeStamp
                              → when (timeStamp ≤ lastTime)
                                $ abort
                                $ mkAbortion' statusForIfModSince
                              → 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
                          Nothing
                              → abort $ mkAbortion' BadRequest

-                                     $ "Malformed If-Modified-Since: " ⊕ A.toText str
+                                     $ "Malformed If-Modified-Since: " ⊕ cs str

            Nothing  → return ()
 
          ifUnmodSince ← getHeader "If-Unmodified-Since"
            Nothing  → return ()
 
          ifUnmodSince ← getHeader "If-Unmodified-Since"


@@ -485,10 +483,10 @@ foundTimeStamp timeStamp
                              → when (timeStamp > lastTime)
                                $ abort
                                $ mkAbortion' PreconditionFailed
                              → 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
                          Nothing
                              → abort $ mkAbortion' BadRequest

-                                     $ "Malformed If-Unmodified-Since: " ⊕ A.toText str
+                                     $ "Malformed If-Unmodified-Since: " ⊕ cs str

            Nothing  → return ()
 
          driftTo ReceivingBody
            Nothing  → return ()
 
          driftTo ReceivingBody


@@ -555,7 +553,7 @@ getChunks' limit = go limit (∅)
                     else
                         abort $ mkAbortion' RequestEntityTooLarge
                               $ "Request body must be smaller than "
                     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
                               ⊕ " bytes."
       go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
                     if Strict.null c then


@@ -587,10 +585,9 @@ getForm limit
                → readMultipartFormData params
            Just cType
                → abort $ mkAbortion' UnsupportedMediaType
                → 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)
     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)


@@ -598,9 +595,9 @@ getForm limit
             (bsToAscii =≪ getChunks limit)
 
       bsToAscii bs
             (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
 
       readMultipartFormData m
           = case lookup "boundary" m of


@@ -608,13 +605,13 @@ getForm limit
                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
               Just boundary
                   → do src ← getChunks 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
                        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
 
 -- |@'redirect' code uri@ declares the response status as @code@ and
 -- \"Location\" header field as @uri@. The @code@ must satisfy


@@ -624,10 +621,9 @@ redirect sc uri
     = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
              $ abort
              $ mkAbortion' InternalServerError
     = 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
 
          setStatus sc
          setLocation uri
 


@@ -635,17 +631,16 @@ redirect sc uri
 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
 -- mandatory for sending a response body.
 setContentType ∷ MIMEType → Rsrc ()
 -- \"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
 
 -- |@'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 ""
 
     where
       uriStr = uriToString id uri ""
 


@@ -660,12 +655,13 @@ setContentEncoding codings
                   _               → abort $ mkAbortion' InternalServerError
                                             "setContentEncoding: Unknown HTTP version"
          setHeader "Content-Encoding"
                   _               → abort $ mkAbortion' InternalServerError
                                             "setContentEncoding: Unknown HTTP version"
          setHeader "Content-Encoding"

-             $ A.fromAsciiBuilder
+             $ cs

              $ mconcat
              $ mconcat

-             $ intersperse (A.toAsciiBuilder ", ")
+             $ intersperse (cs (", " ∷ Ascii))

              $ map tr codings
     where
              $ 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' challenge@ declares the response header
 -- \"WWW-Authenticate\" as @challenge@.