From bb41be0c967538a1014c87103a3a5d3840ad3e15 Mon Sep 17 00:00:00 2001 From: PHO Date: Mon, 19 Dec 2011 17:26:28 +0900 Subject: [PATCH] Code clean-up using convertible-text. Ditz-issue: 0a2a377be55430e655ab42fdc4902fa56a058b26 --- Network/HTTP/Lucu/DefaultPage.hs | 9 +++- Network/HTTP/Lucu/MIMEType/Guess.hs | 6 +-- Network/HTTP/Lucu/MultipartForm.hs | 26 ++++++---- Network/HTTP/Lucu/Postprocess.hs | 21 ++++---- Network/HTTP/Lucu/Resource.hs | 63 ++++++++++++------------ Network/HTTP/Lucu/Response.hs | 42 ++++++++-------- Network/HTTP/Lucu/ResponseWriter.hs | 11 +++-- Network/HTTP/Lucu/StatusCode/Internal.hs | 24 ++++++++- 8 files changed, 119 insertions(+), 83 deletions(-) diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index e106774..d952917 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings , RecordWildCards + , ScopedTypeVariables , TypeOperators , UnicodeSyntax #-} @@ -14,6 +15,7 @@ import Blaze.ByteString.Builder (Builder) import Data.Ascii (Ascii) import qualified Data.Ascii as A import qualified Data.CaseInsensitive as CI +import Data.Convertible.Utils import Data.Maybe import Data.Monoid.Unicode import Data.Text (Text) @@ -38,14 +40,14 @@ defaultPageForResponse ∷ Config → Maybe Request → Response → Builder defaultPageForResponse conf req res = defaultPageWithMessage conf (resStatus res) $ defaultMessage req res -defaultPageWithMessage ∷ StatusCode sc ⇒ Config → sc → Html → Builder +defaultPageWithMessage ∷ ∀sc. StatusCode sc ⇒ Config → sc → Html → Builder {-# INLINEABLE defaultPageWithMessage #-} defaultPageWithMessage (Config {..}) sc msg = renderHtmlBuilder $ do unsafeByteString "" docType html ! xmlns "http://www.w3.org/1999/xhtml" $ - do let status = toHtml ∘ A.toText ∘ A.fromAsciiBuilder $ printStatusCode sc + do let status = toHtml $ scText sc head $ title status body $ do h1 status p msg @@ -53,6 +55,9 @@ defaultPageWithMessage (Config {..}) sc msg address $ do toHtml $ A.toText cnfServerSoftware unsafeByteString " at " toHtml $ CI.original cnfServerHost + where + scText ∷ sc → Text + scText = convertSuccessVia ((⊥) ∷ Ascii) ∘ fromStatusCode defaultMessage ∷ Maybe Request → Response → Html {-# INLINEABLE defaultMessage #-} diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index d77c976..6a791e4 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -17,8 +17,8 @@ module Network.HTTP.Lucu.MIMEType.Guess ) where import Control.Applicative -import Data.Attoparsec.Char8 as P -import Data.Attoparsec.Lazy as LP +import Data.Attoparsec.Char8 +import qualified Data.Attoparsec.Lazy as LP import qualified Data.ByteString.Lazy.Char8 as Lazy import qualified Data.Map as M import Data.Map (Map) @@ -103,7 +103,7 @@ parseExtMap src "pair" ext ∷ Parser Text - ext = (decodeUtf8 <$> P.takeWhile1 isAlphaNum) + ext = (decodeUtf8 <$> takeWhile1 isAlphaNum) "ext" diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index 30a4adb..882ff76 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -1,10 +1,13 @@ {-# LANGUAGE DoAndIfThenElse + , FlexibleInstances , FlexibleContexts + , MultiParamTypeClasses , OverloadedStrings , QuasiQuotes , RecordWildCards , ScopedTypeVariables + , TemplateHaskell , UnicodeSyntax , ViewPatterns #-} @@ -19,7 +22,7 @@ import Control.Applicative hiding (many) import Control.Applicative.Unicode hiding ((∅)) import Control.Monad.Error (MonadError, throwError) import Control.Monad.Unicode -import Data.Ascii (Ascii, CIAscii) +import Data.Ascii (Ascii, CIAscii, AsciiBuilder) import qualified Data.Ascii as A import Data.Attoparsec import qualified Data.Attoparsec.Lazy as LP @@ -72,13 +75,18 @@ data ContDispo , dParams ∷ !MIMEParams } --- FIXME -printContDispo ∷ ContDispo → Ascii -printContDispo d - = A.fromAsciiBuilder - ( A.toAsciiBuilder (A.fromCIAscii $ dType d) - ⊕ - cs (dParams d) ) +instance ConvertSuccess ContDispo Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder) + +instance ConvertSuccess ContDispo AsciiBuilder where + {-# INLINE convertSuccess #-} + convertSuccess (ContDispo {..}) + = cs dType ⊕ cs dParams + +deriveAttempts [ ([t| ContDispo |], [t| Ascii |]) + , ([t| ContDispo |], [t| AsciiBuilder |]) + ] -- |Parse \"multipart/form-data\" and return either @'Left' err@ or -- @'Right' result@. Note that there are currently the following @@ -241,7 +249,7 @@ partName (Part {..}) ⧺ T.unpack name Nothing → throwError $ "form-data without name: " - ⧺ A.toString (printContDispo ptContDispo) + ⊕ convertSuccessVia ((⊥) ∷ Ascii) ptContDispo partFileName ∷ Part → Maybe Text partFileName (ptContDispo → ContDispo {..}) diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index a835975..4ba7865 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -13,7 +13,7 @@ import Control.Concurrent.STM import Control.Monad import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii, AsciiBuilder) -import qualified Data.Ascii as A +import Data.Convertible.Base import Data.Maybe import Data.Monoid.Unicode import GHC.Conc (unsafeIOToSTM) @@ -44,29 +44,28 @@ abortOnCertainConditions (NI {..}) , isError ]) $ abort' - $ A.toAsciiBuilder "Inappropriate status code for a response: " - ⊕ printStatusCode resStatus + $ cs ("Inappropriate status code for a response: " ∷ Ascii) + ⊕ cs resStatus when ( resStatus ≈ MethodNotAllowed ∧ hasHeader "Allow" res ) $ abort' - $ A.toAsciiBuilder "The status was " - ⊕ printStatusCode resStatus - ⊕ A.toAsciiBuilder " but no \"Allow\" header." + $ cs ("The status was " ∷ Ascii) + ⊕ cs resStatus + ⊕ cs (" but no \"Allow\" header." ∷ Ascii) when ( resStatus ≉ NotModified ∧ isRedirection resStatus ∧ hasHeader "Location" res ) $ abort' - $ A.toAsciiBuilder "The status code was " - ⊕ printStatusCode resStatus - ⊕ A.toAsciiBuilder " but no Location header." + $ cs ("The status code was " ∷ Ascii) + ⊕ cs resStatus + ⊕ cs (" but no Location header." ∷ Ascii) abort' ∷ AsciiBuilder → STM () abort' = throwSTM ∘ mkAbortion' InternalServerError - ∘ A.toText - ∘ A.fromAsciiBuilder + ∘ cs postprocessWithRequest ∷ NormalInteraction → STM () postprocessWithRequest ni@(NI {..}) diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index b478503..a970b46 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -156,6 +156,8 @@ 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 @@ -234,8 +236,7 @@ getQueryForm = parse' <$> getRequestURI where parse' = map toPairWithFormData ∘ parseWWWFormURLEncoded ∘ - fromJust ∘ - A.fromChars ∘ + convertUnsafe ∘ drop 1 ∘ uriQuery @@ -265,10 +266,10 @@ getAccept Nothing → return [] Just accept - → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of + → case P.parseOnly (finishOff MT.mimeTypeList) (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 @@ -293,10 +294,10 @@ getAcceptEncoding -- identity のみが許される。 return [("identity", Nothing)] else - case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of + case P.parseOnly (finishOff acceptEncodingList) (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) @@ -317,10 +318,10 @@ getContentType Nothing → return Nothing Just cType - → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of + → case P.parseOnly (finishOff MT.mimeType) (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'. @@ -331,7 +332,7 @@ getAuthorization Nothing → return Nothing Just auth - → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of + → case P.parseOnly (finishOff authCredential) (cs auth) of Right ac → return $ Just ac Left _ → return Nothing @@ -379,7 +380,6 @@ foundETag tag method ← getMethod when (method ≡ GET ∨ method ≡ HEAD) $ setHeader "ETag" - $ A.fromAsciiBuilder $ cs tag when (method ≡ POST) $ abort @@ -395,17 +395,17 @@ foundETag tag → if value ≡ "*" then return () else - case P.parseOnly (finishOff eTagList) (A.toByteString value) of + case P.parseOnly (finishOff eTagList) (cs value) of 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 @@ -423,15 +423,15 @@ foundETag tag abort $ mkAbortion' statusForNoneMatch $ "The entity tag matches: *" else - case P.parseOnly (finishOff eTagList) (A.toByteString value) of + case P.parseOnly (finishOff eTagList) (cs value) of 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 @@ -472,10 +472,10 @@ foundTimeStamp timeStamp → 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 - $ "Malformed If-Modified-Since: " ⊕ A.toText str + $ "Malformed If-Modified-Since: " ⊕ cs str Nothing → return () ifUnmodSince ← getHeader "If-Unmodified-Since" @@ -485,10 +485,10 @@ foundTimeStamp timeStamp → 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 - $ "Malformed If-Unmodified-Since: " ⊕ A.toText str + $ "Malformed If-Unmodified-Since: " ⊕ cs str Nothing → return () driftTo ReceivingBody @@ -597,9 +597,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 @@ -607,12 +607,12 @@ 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 + Right xs → return $ map (first cs) xs Left err → abort $ mkAbortion' BadRequest $ T.pack err -- |@'redirect' code uri@ declares the response status as @code@ and @@ -623,10 +623,9 @@ redirect sc uri = 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 diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index e9da057..8f45440 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -1,6 +1,9 @@ {-# LANGUAGE - OverloadedStrings + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings , RecordWildCards + , TemplateHaskell , UnicodeSyntax , ViewPatterns #-} @@ -17,8 +20,6 @@ module Network.HTTP.Lucu.Response , emptyResponse , setStatusCode , resCanHaveBody - , printStatusCode - , printResponse , (≈) , (≉) @@ -30,8 +31,7 @@ module Network.HTTP.Lucu.Response , isServerError ) where -import Data.Ascii (AsciiBuilder) -import qualified Data.Ascii as A +import Data.Ascii (Ascii, AsciiBuilder) import Data.Convertible.Base import Data.Convertible.Instances.Ascii () import Data.Convertible.Utils @@ -42,11 +42,6 @@ import Network.HTTP.Lucu.StatusCode import Network.HTTP.Lucu.StatusCode.Internal import Prelude.Unicode --- |Convert a 'StatusCode' to an 'AsciiBuilder'. -printStatusCode ∷ StatusCode sc ⇒ sc → AsciiBuilder -{-# INLINEABLE printStatusCode #-} -printStatusCode = A.toAsciiBuilder ∘ textualStatus - -- |This is the definition of an HTTP response. data Response = Response { resVersion ∷ !HttpVersion @@ -58,6 +53,23 @@ instance HasHeaders Response where getHeaders = resHeaders setHeaders res hdr = res { resHeaders = hdr } +instance ConvertSuccess Response Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder) + +instance ConvertSuccess Response AsciiBuilder where + {-# INLINE convertSuccess #-} + convertSuccess (Response {..}) + = cs resVersion ⊕ + cs (" " ∷ Ascii) ⊕ + cs resStatus ⊕ + cs ("\x0D\x0A" ∷ Ascii) ⊕ + cs resHeaders + +deriveAttempts [ ([t| Response |], [t| Ascii |]) + , ([t| Response |], [t| AsciiBuilder |]) + ] + -- |Returns an HTTP\/1.1 'Response' with no header fields. emptyResponse ∷ StatusCode sc ⇒ sc → Response emptyResponse sc @@ -85,16 +97,6 @@ resCanHaveBody (Response {..}) | resStatus ≈ NotModified = False | otherwise = True --- |Convert a 'Response' to 'AsciiBuilder'. -printResponse ∷ Response → AsciiBuilder -{-# INLINEABLE printResponse #-} -printResponse (Response {..}) - = cs resVersion ⊕ - A.toAsciiBuilder " " ⊕ - printStatusCode resStatus ⊕ - A.toAsciiBuilder "\x0D\x0A" ⊕ - cs resHeaders - -- |@'isInformational' sc@ returns 'True' iff @sc '<' 200@. isInformational ∷ StatusCode sc ⇒ sc → Bool {-# INLINE isInformational #-} diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index b4809ea..15f3d68 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -14,8 +14,9 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Control.Monad +import Data.Ascii (AsciiBuilder) +import Data.Convertible.Utils import GHC.IO.Exception (IOException(..), IOErrorType(..)) -import qualified Data.Ascii as A import Data.Monoid.Unicode import qualified Data.Sequence as S import Data.Sequence (ViewR(..)) @@ -102,7 +103,7 @@ writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..}) , resStatus = fromStatusCode Continue , resHeaders = (∅) } - hPutBuilder cHandle $ A.toBuilder $ printResponse cont + hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) cont hFlush cHandle writeHeader ctx ni @@ -117,7 +118,7 @@ writeHeader ctx@(Context {..}) ni@(NI {..}) readTVar niResponse else retry -- Too early to write header fields. - hPutBuilder cHandle $ A.toBuilder $ printResponse res + hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) res hFlush cHandle writeBodyIfNeeded ctx ni @@ -231,7 +232,7 @@ writeResponseForSEI ∷ HandleLike h → SemanticallyInvalidInteraction → IO () writeResponseForSEI ctx@(Context {..}) (SEI {..}) - = do hPutBuilder cHandle $ A.toBuilder $ printResponse seiResponse + = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) seiResponse unless seiWillDiscardBody $ if seiWillChunkBody then do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend @@ -249,7 +250,7 @@ writeResponseForSYI ∷ HandleLike h → SyntacticallyInvalidInteraction → IO () writeResponseForSYI (Context {..}) (SYI {..}) - = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse + = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) syiResponse hPutBuilder cHandle syiBodyToSend hFlush cHandle return () diff --git a/Network/HTTP/Lucu/StatusCode/Internal.hs b/Network/HTTP/Lucu/StatusCode/Internal.hs index d6e892b..1d9117c 100644 --- a/Network/HTTP/Lucu/StatusCode/Internal.hs +++ b/Network/HTTP/Lucu/StatusCode/Internal.hs @@ -1,10 +1,13 @@ {-# LANGUAGE ExistentialQuantification , FlexibleInstances + , MultiParamTypeClasses + , OverlappingInstances , TemplateHaskell , UnicodeSyntax , ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Network.HTTP.Lucu.StatusCode.Internal ( StatusCode(..) , SomeStatusCode(..) @@ -14,11 +17,14 @@ module Network.HTTP.Lucu.StatusCode.Internal ) where import Control.Applicative -import Data.Ascii (Ascii) +import Data.Ascii (Ascii, AsciiBuilder) import qualified Data.Ascii as A import Data.Attoparsec.Char8 as P import Data.Attoparsec.Lazy as LP import qualified Data.ByteString.Lazy.Char8 as Lazy +import Data.Convertible.Base +import Data.Convertible.Instances.Ascii () +import Data.Convertible.Utils import Data.List import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax @@ -73,6 +79,22 @@ instance StatusCode SomeStatusCode where textualStatus (SomeStatusCode sc) = textualStatus sc fromStatusCode = id +instance StatusCode sc ⇒ ConvertSuccess sc Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder) + +instance StatusCode sc ⇒ ConvertSuccess sc AsciiBuilder where + {-# INLINE convertSuccess #-} + convertSuccess = cs ∘ textualStatus + +instance StatusCode sc ⇒ ConvertAttempt sc Ascii where + {-# INLINE convertAttempt #-} + convertAttempt = return ∘ cs + +instance StatusCode sc ⇒ ConvertAttempt sc AsciiBuilder where + {-# INLINE convertAttempt #-} + convertAttempt = return ∘ cs + -- |'QuasiQuoter' for 'StatusCode' declarations. -- -- Top-level splicing -- 2.40.0