From: PHO Date: Mon, 19 Dec 2011 07:13:24 +0000 (+0900) Subject: Code clean-up using convertible-text. X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=0678be8;p=Lucu.git Code clean-up using convertible-text. Ditz-issue: 0a2a377be55430e655ab42fdc4902fa56a058b26 --- diff --git a/ImplantFile.hs b/ImplantFile.hs index 60f9b54..cbada79 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -4,8 +4,11 @@ module Main (main) where import Control.Applicative import Control.Monad -import qualified Data.Ascii as A +import Data.Ascii (Ascii) +import Data.Attempt import Data.Char +import Data.Convertible.Base +import Data.Convertible.Utils import Data.Maybe import Language.Haskell.TH.PprLib import Language.Haskell.TH.Syntax @@ -97,9 +100,9 @@ getMIMEType opts = case mimeTypeOpts of [] → Nothing OptMIMEType ty:[] - → case A.fromChars ty of - Just a → Just $ parseMIMEType a - Nothing → error "MIME types must not contain any non-ASCII letters." + → case convertAttemptVia ((⊥) ∷ Ascii) ty of + Success a → Just a + Failure e → error (show e) _ → error "too many --mime-type options." where mimeTypeOpts ∷ [CmdOpt] @@ -122,9 +125,9 @@ getETag opts strToETag ∷ String → ETag strToETag str - = case A.fromChars str of - Just a → strongETag a - Nothing → error "ETag must not contain any non-ASCII letters." + = case ca str of + Success a → strongETag a + Failure e → error (show e) openOutput ∷ [CmdOpt] → IO Handle openOutput opts diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index a3f73be..876064c 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -63,7 +63,6 @@ module Network.HTTP.Lucu -- *** MIME Type , MIMEType(..) , MIMEParams - , parseMIMEType , mimeType -- *** Authentication diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index d4c51d5..e56567e 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -111,11 +111,12 @@ instance ConvertSuccess Headers Ascii where convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder) instance ConvertSuccess Headers AsciiBuilder where - {-# INLINE convertSuccess #-} + {-# INLINEABLE convertSuccess #-} convertSuccess (Headers m) = mconcat (header <$> fromFoldable m) ⊕ cs ("\x0D\x0A" ∷ Ascii) where header ∷ (CIAscii, Ascii) → AsciiBuilder + {-# INLINE header #-} header (name, value) = cs name ⊕ cs (": " ∷ Ascii) ⊕ diff --git a/Network/HTTP/Lucu/Implant/PrettyPrint.hs b/Network/HTTP/Lucu/Implant/PrettyPrint.hs index 5bbc36d..22e3a74 100644 --- a/Network/HTTP/Lucu/Implant/PrettyPrint.hs +++ b/Network/HTTP/Lucu/Implant/PrettyPrint.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DoAndIfThenElse + , FlexibleContexts + , MultiParamTypeClasses , OverloadedStrings , RecordWildCards , TemplateHaskell @@ -15,10 +17,10 @@ module Network.HTTP.Lucu.Implant.PrettyPrint import Codec.Compression.GZip import Control.Monad import Data.Ascii (Ascii, CIAscii) -import qualified Data.Ascii as A import qualified Data.ByteString.Lazy as L import Data.Char import Data.Collections +import Data.Convertible.Base import Data.Convertible.Utils import Data.List (intersperse) import Data.Monoid @@ -60,19 +62,16 @@ header i@(Input {..}) ] else text " Compression: disabled" - , text " MIME Type:" <+> mimeTypeToDoc iType - , text " ETag:" <+> eTagToDoc iETag + , text " MIME Type:" <+> toDoc iType + , text " ETag:" <+> toDoc iETag , text " Last Modified:" <+> text (show iLastMod) ] , text " -}" , text "{-# LANGUAGE MagicHash #-}" ] where - eTagToDoc ∷ ETag → Doc - eTagToDoc = text ∘ convertSuccessVia ((⊥) ∷ Ascii) - - mimeTypeToDoc ∷ MIMEType → Doc - mimeTypeToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType + toDoc ∷ ConvertSuccess α Ascii ⇒ α → Doc + toDoc = text ∘ convertSuccessVia ((⊥) ∷ Ascii) moduleDecl ∷ ModName → Name → Doc moduleDecl modName symName diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs index a2b9341..88dbb6f 100644 --- a/Network/HTTP/Lucu/MIMEParams.hs +++ b/Network/HTTP/Lucu/MIMEParams.hs @@ -62,7 +62,7 @@ instance ConvertSuccess MIMEParams Ascii where convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder) instance ConvertSuccess MIMEParams AsciiBuilder where - {-# INLINE convertSuccess #-} + {-# INLINEABLE convertSuccess #-} convertSuccess = foldl' f (∅) where f ∷ AsciiBuilder → (CIAscii, Text) → AsciiBuilder @@ -119,6 +119,10 @@ toHex o = cs ("%" ∷ Ascii) ⊕ | otherwise = toEnum $ fromIntegral $ fromEnum 'A' + fromIntegral (h - 0x0A) +deriveAttempts [ ([t| MIMEParams |], [t| Ascii |]) + , ([t| MIMEParams |], [t| AsciiBuilder |]) + ] + data ExtendedParam = InitialEncodedParam { epName ∷ !CIAscii diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index 68e9b25..1c448ee 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveDataTypeable + , FlexibleInstances + , MultiParamTypeClasses , OverloadedStrings , RecordWildCards , TemplateHaskell @@ -9,10 +11,6 @@ -- (). module Network.HTTP.Lucu.MIMEType ( MIMEType(..) - - , parseMIMEType - , printMIMEType - , mimeType , mimeTypeList ) @@ -51,24 +49,30 @@ instance Lift MIMEType where } |] --- |Convert a 'MIMEType' to an 'AsciiBuilder'. -printMIMEType ∷ MIMEType → AsciiBuilder -{-# INLINEABLE printMIMEType #-} -printMIMEType (MIMEType {..}) - = A.toAsciiBuilder (A.fromCIAscii mtMedia) ⊕ - A.toAsciiBuilder "/" ⊕ - A.toAsciiBuilder (A.fromCIAscii mtSub) ⊕ - cs mtParams +instance ConvertSuccess MIMEType Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder) + +instance ConvertSuccess MIMEType AsciiBuilder where + {-# INLINEABLE convertSuccess #-} + convertSuccess (MIMEType {..}) + = cs mtMedia ⊕ + cs ("/" ∷ Ascii) ⊕ + cs mtSub ⊕ + cs mtParams + +deriveAttempts [ ([t| MIMEType |], [t| Ascii |]) + , ([t| MIMEType |], [t| AsciiBuilder |]) + ] --- |Parse 'MIMEType' from an 'Ascii'. This function throws an --- exception for parse error. For literals consider using --- 'Network.HTTP.Lucu.MIMEType.TH.mimeType'. -parseMIMEType ∷ Ascii → MIMEType -{-# INLINEABLE parseMIMEType #-} -parseMIMEType str - = case parseOnly (finishOff mimeType) $ A.toByteString str of - Right t → t - Left err → error ("Unparsable MIME Type: " ⧺ A.toString str ⧺ ": " ⧺ err) +-- |Parse 'MIMEType' from an 'Ascii'. For MIME type literals, consider +-- using 'Network.HTTP.Lucu.MIMEType.TH.mimeType'. +instance ConvertAttempt Ascii MIMEType where + {-# INLINEABLE convertAttempt #-} + convertAttempt str + = case parseOnly (finishOff mimeType) (cs str) of + Right t → return t + Left err → fail ("Unparsable MIME Type: " ⧺ cs str ⧺ ": " ⧺ err) -- |'Parser' for an 'MIMEType'. mimeType ∷ Parser MIMEType diff --git a/Network/HTTP/Lucu/MIMEType/TH.hs b/Network/HTTP/Lucu/MIMEType/TH.hs index 7cdf244..9e16efc 100644 --- a/Network/HTTP/Lucu/MIMEType/TH.hs +++ b/Network/HTTP/Lucu/MIMEType/TH.hs @@ -9,7 +9,8 @@ module Network.HTTP.Lucu.MIMEType.TH where import Control.Monad.Unicode import Data.Ascii (Ascii) -import qualified Data.Ascii as A +import Data.Attempt +import Data.Convertible.Base import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote import Network.HTTP.Lucu.MIMEType hiding (mimeType) @@ -24,15 +25,23 @@ import Prelude.Unicode -- @ mimeType ∷ QuasiQuoter mimeType = QuasiQuoter { - quoteExp = (lift ∘ parseMIMEType =≪) ∘ toAscii + quoteExp = (lift =≪) ∘ (parse =≪) ∘ toAscii , quotePat = const unsupported , quoteType = const unsupported , quoteDec = const unsupported } where + parse ∷ Monad m ⇒ Ascii → m MIMEType + parse a + = case ca a of + Success t → return t + Failure e → fail (show e) + toAscii ∷ Monad m ⇒ String → m Ascii - toAscii (A.fromChars ∘ trim → Just a) = return a - toAscii str = fail $ "Malformed MIME Type: " ⧺ str + toAscii (trim → s) + = case ca s of + Success a → return a + Failure e → fail (show e) unsupported ∷ Monad m ⇒ m α unsupported = fail "Unsupported usage of mimeType quasi-quoter." diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index a5280c0..30a4adb 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -27,6 +27,9 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LS import Data.ByteString.Lazy.Search import Data.Collections +import Data.Convertible.Base +import Data.Convertible.Instances.Ascii () +import Data.Convertible.Utils import Data.List (intercalate) import Data.Maybe import Data.Monoid.Unicode @@ -69,12 +72,13 @@ data ContDispo , dParams ∷ !MIMEParams } +-- FIXME printContDispo ∷ ContDispo → Ascii printContDispo d = A.fromAsciiBuilder ( A.toAsciiBuilder (A.fromCIAscii $ dType d) ⊕ - printMIMEParams (dParams d) ) + cs (dParams d) ) -- |Parse \"multipart/form-data\" and return either @'Left' err@ or -- @'Right' result@. Note that there are currently the following diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 6f3ecce..b478503 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -587,10 +587,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) @@ -635,8 +634,7 @@ 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.