From: PHO <pho@cielonegro.org>
Date: Sat, 5 Nov 2011 03:51:34 +0000 (+0900)
Subject: Make use of mimeType quasi-quoter.
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=b1fac0a2cb1cafa008c0efa8ae4e14afbee0927f;p=Lucu.git
Make use of mimeType quasi-quoter.
Ditz-issue: c566a8433e8af700655680f53e99cfe9f563ed32
---
diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs
index d45beaf..58cb486 100644
--- a/Network/HTTP/Lucu.hs
+++ b/Network/HTTP/Lucu.hs
@@ -57,8 +57,8 @@ module Network.HTTP.Lucu
-- *** MIME Type
, MIMEType(..)
- , mkMIMEType
, parseMIMEType
+ , mimeType
-- *** Authentication
, AuthChallenge(..)
@@ -74,7 +74,8 @@ import Network.HTTP.Lucu.Authentication
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.ETag
import Network.HTTP.Lucu.Httpd
-import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.MIMEType hiding (mimeType)
+import Network.HTTP.Lucu.MIMEType.TH
import Network.HTTP.Lucu.Resource
import Network.HTTP.Lucu.Resource.Tree
import Network.HTTP.Lucu.Response
diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs
index 9c34c50..d60b70e 100644
--- a/Network/HTTP/Lucu/MIMEType.hs
+++ b/Network/HTTP/Lucu/MIMEType.hs
@@ -9,7 +9,6 @@
-- (<http://tools.ietf.org/html/rfc2046>).
module Network.HTTP.Lucu.MIMEType
( MIMEType(..)
- , mkMIMEType
, parseMIMEType
, printMIMEType
@@ -49,12 +48,6 @@ instance Lift MIMEType where
}
|]
--- |@'mkMIMEType' media sub@ returns a 'MIMEType' with the given
--- @media@ and @sub@ types but without any parameters.
-mkMIMEType â· CIAscii â CIAscii â MIMEType
-{-# INLINE mkMIMEType #-}
-mkMIMEType = flip flip (â
) â MIMEType
-
-- |Convert a 'MIMEType' to an 'AsciiBuilder'.
printMIMEType â· MIMEType â AsciiBuilder
{-# INLINEABLE printMIMEType #-}
diff --git a/Network/HTTP/Lucu/MIMEType/TH.hs b/Network/HTTP/Lucu/MIMEType/TH.hs
index 1aae0b4..7cdf244 100644
--- a/Network/HTTP/Lucu/MIMEType/TH.hs
+++ b/Network/HTTP/Lucu/MIMEType/TH.hs
@@ -2,6 +2,7 @@
UnicodeSyntax
, ViewPatterns
#-}
+-- |A module to provide 'QuasiQuoter' for 'MIMEType' literals.
module Network.HTTP.Lucu.MIMEType.TH
( mimeType
)
@@ -15,11 +16,11 @@ import Network.HTTP.Lucu.MIMEType hiding (mimeType)
import Network.HTTP.Lucu.Utils
import Prelude.Unicode
--- |A 'QuasiQuoter' for 'MIMEType' literals.
+-- |'QuasiQuoter' for 'MIMEType' literals.
--
-- @
-- textPlain :: 'MIMEType'
--- textPlain = ['mimeType'| text/plain; charset="UTF-8" |]
+-- textPlain = ['mimeType'| text/plain; charset=\"UTF-8\" |]
-- @
mimeType â· QuasiQuoter
mimeType = QuasiQuoter {
diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index fd85eaf..a28a804 100644
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -2,6 +2,7 @@
DoAndIfThenElse
, FlexibleContexts
, OverloadedStrings
+ , QuasiQuotes
, RecordWildCards
, ScopedTypeVariables
, UnicodeSyntax
@@ -38,7 +39,9 @@ import Data.Text (Text)
import qualified Data.Text as T
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.MIMEParams
-import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.MIMEType (MIMEType)
+import qualified Network.HTTP.Lucu.MIMEType as MT
+import Network.HTTP.Lucu.MIMEType.TH
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
import Prelude.Unicode
@@ -155,7 +158,7 @@ parsePart boundary src
⧺ e
where
defaultCType â· MIMEType
- defaultCType = parseMIMEType "text/plain"
+ defaultCType = [mimeType| text/plain |]
partHeader â· Parser Headers
partHeader = crlf *> headers
@@ -187,7 +190,7 @@ getContType hdrs
Nothing
â return Nothing
Just str
- â case parseOnly (finishOff mimeType) $ A.toByteString str of
+ â case parseOnly (finishOff MT.mimeType) $ A.toByteString str of
Right d â return $ Just d
Left err â throwError $ "malformed Content-Type: "
⧺ A.toString str
diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index e6a03ac..704feda 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -3,6 +3,7 @@
, GeneralizedNewtypeDeriving
, DoAndIfThenElse
, OverloadedStrings
+ , QuasiQuotes
, RecordWildCards
, UnicodeSyntax
#-}
@@ -174,7 +175,9 @@ import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.MIMEParams
-import Network.HTTP.Lucu.MIMEType
+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)
@@ -236,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)
@@ -258,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
@@ -310,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
@@ -580,7 +583,7 @@ getForm limit
$ A.toText
$ A.fromAsciiBuilder
$ A.toAsciiBuilder "Unsupported media type: "
- â printMIMEType cType
+ â MT.printMIMEType cType
where
readWWWFormURLEncoded
= (map toPairWithFormData â parseWWWFormURLEncoded)
@@ -626,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.