From: PHO Date: Mon, 19 Dec 2011 12:17:28 +0000 (+0900) Subject: Code clean-up using convertible-text. X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=c9a269666f2d60d9c5ba817e1c43b45f6d77de22;p=Lucu.git Code clean-up using convertible-text. Ditz-issue: 0a2a377be55430e655ab42fdc4902fa56a058b26 --- diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index 366a63c..d1afdc0 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -14,9 +14,10 @@ module Network.HTTP.Lucu.Config import Data.Ascii (Ascii) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import Data.Convertible.Base +import Data.Convertible.Instances.Text () import Data.Default import Data.Text (Text) -import qualified Data.Text as T import Network import Network.BSD import Network.HTTP.Lucu.MIMEType.Guess @@ -108,7 +109,7 @@ data SSLConfig instance Default Config where def = Config { cnfServerSoftware = "Lucu/1.0" - , cnfServerHost = CI.mk ∘ T.pack $ unsafePerformIO getHostName + , cnfServerHost = CI.mk ∘ cs $ unsafePerformIO getHostName , cnfServerPort = "http" , cnfServerV4Addr = Just "0.0.0.0" , cnfServerV6Addr = Just "::" diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index e56567e..f0e6ad8 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -57,7 +57,7 @@ class HasHeaders a where getCIHeader ∷ CIAscii → a → Maybe CIAscii {-# INLINE getCIHeader #-} - getCIHeader = ((A.toCIAscii <$>) ∘) ∘ getHeader + getCIHeader = ((cs <$>) ∘) ∘ getHeader deleteHeader ∷ CIAscii → a → a {-# INLINE deleteHeader #-} @@ -145,7 +145,7 @@ headers = do xs ← many header return $ fromFoldable xs where header ∷ Parser (CIAscii, Ascii) - header = do name ← A.toCIAscii <$> token + header = do name ← cs <$> token void $ char ':' skipMany lws values ← content `sepBy` try lws @@ -161,7 +161,7 @@ headers = do xs ← many header joinValues ∷ [Ascii] → Ascii {-# INLINE joinValues #-} - joinValues = A.fromAsciiBuilder + joinValues = cs ∘ mconcat - ∘ intersperse (A.toAsciiBuilder "\x20") - ∘ (A.toAsciiBuilder <$>) + ∘ intersperse (cs ("\x20" ∷ Ascii) ∷ AsciiBuilder) + ∘ (cs <$>) diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs index 88dbb6f..6f9eb7e 100644 --- a/Network/HTTP/Lucu/MIMEParams.hs +++ b/Network/HTTP/Lucu/MIMEParams.hs @@ -168,7 +168,7 @@ paramP = do skipMany lws return $ AsciiParam name sect payload nameP ∷ Parser (CIAscii, Integer, Bool) -nameP = do name ← (A.toCIAscii ∘ A.unsafeFromByteString) <$> +nameP = do name ← (cs ∘ A.unsafeFromByteString) <$> takeWhile1 (\c → isToken c ∧ c ≢ '*') sect ← option 0 $ try (char '*' *> decimal ) isEncoded ← option False $ try (char '*' *> pure True) @@ -190,7 +190,7 @@ initialEncodedValue return (charset, payload) where metadata ∷ Parser CIAscii - metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$> + metadata = (cs ∘ A.unsafeFromByteString) <$> takeWhile (\c → c ≢ '\'' ∧ isToken c) encodedPayload ∷ Parser BS.ByteString @@ -257,7 +257,7 @@ sortBySection = flip go (∅) → fail (concat [ "Duplicate section " , show $ section x , " for parameter '" - , A.toString $ A.fromCIAscii $ epName x + , cs $ epName x , "'" ]) @@ -280,7 +280,7 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) → fail (concat [ "Missing section " , show $ section p , " for parameter '" - , A.toString $ A.fromCIAscii $ epName p + , cs $ epName p , "'" ]) @@ -296,9 +296,7 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) Just (ContinuedEncodedParam {..}, _) → fail "decodeSeq: internal error: CEP at section 0" Just (AsciiParam {..}, xs) - → let t = A.toText apPayload - in - decodeSeq' Nothing xs $ singleton t + → decodeSeq' Nothing xs $ singleton $ cs apPayload decodeSeq' ∷ Monad m ⇒ Maybe Decoder @@ -320,13 +318,11 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) → fail (concat [ "Section " , show epSection , " for parameter '" - , A.toString $ A.fromCIAscii epName + , cs epName , "' is encoded but its first section is not" ]) Just (AsciiParam {..}, xs) - → let t = A.toText apPayload - in - decodeSeq' decoder xs $ chunks ⊳ t + → decodeSeq' decoder xs $ chunks ⊳ cs apPayload type Decoder = BS.ByteString → Either UnicodeException Text @@ -340,5 +336,4 @@ getDecoder ∷ Monad m ⇒ CIAscii → m Decoder getDecoder charset | charset ≡ "UTF-8" = return decodeUtf8' | charset ≡ "US-ASCII" = return decodeUtf8' - | otherwise = fail $ "No decoders found for charset: " - ⧺ A.toString (A.fromCIAscii charset) + | otherwise = fail $ "No decoders found for charset: " ⊕ cs charset diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index 1c448ee..250fdbf 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -17,8 +17,7 @@ module Network.HTTP.Lucu.MIMEType where import Control.Applicative import Data.Ascii (Ascii, AsciiBuilder, CIAscii) -import qualified Data.Ascii as A -import Data.Attoparsec.Char8 as P +import Data.Attoparsec.Char8 import Data.Convertible.Base import Data.Convertible.Instances.Ascii () import Data.Convertible.Utils @@ -77,9 +76,9 @@ instance ConvertAttempt Ascii MIMEType where -- |'Parser' for an 'MIMEType'. mimeType ∷ Parser MIMEType {-# INLINEABLE mimeType #-} -mimeType = do media ← A.toCIAscii <$> token +mimeType = do media ← cs <$> token _ ← char '/' - sub ← A.toCIAscii <$> token + sub ← cs <$> token params ← mimeParams return $ MIMEType media sub params diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 6a791e4..cd178de 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -20,6 +20,8 @@ import Control.Applicative import Data.Attoparsec.Char8 import qualified Data.Attoparsec.Lazy as LP import qualified Data.ByteString.Lazy.Char8 as Lazy +import Data.Convertible.Base +import Data.Convertible.Instances.Text () import qualified Data.Map as M import Data.Map (Map) import Data.Typeable @@ -27,7 +29,6 @@ import Data.List import Data.Monoid import Data.Monoid.Unicode import Data.Text (Text) -import qualified Data.Text as T import Data.Text.Encoding import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote @@ -137,4 +138,4 @@ guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType guessTypeByFileName (ExtMap m) fpath = case takeExtension fpath of [] → Nothing - (_:ext) → M.lookup (T.pack ext) m + (_:ext) → M.lookup (cs ext) m diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index 882ff76..2d1b347 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -23,7 +23,7 @@ import Control.Applicative.Unicode hiding ((∅)) import Control.Monad.Error (MonadError, throwError) import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii, AsciiBuilder) -import qualified Data.Ascii as A +import Data.Attempt import Data.Attoparsec import qualified Data.Attoparsec.Lazy as LP import qualified Data.ByteString as BS @@ -38,7 +38,6 @@ import Data.Maybe import Data.Monoid.Unicode import Data.Sequence (Seq) 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 (MIMEType) @@ -136,7 +135,7 @@ prologue ∷ Ascii → Parser () prologue boundary = ( (string "--" "prefix") *> - (string (A.toByteString boundary) "boundary") + (string (cs boundary) "boundary") *> pure () ) @@ -180,16 +179,16 @@ getContDispo hdrs Nothing → throwError "Content-Disposition is missing" Just str - → case parseOnly (finishOff contentDisposition) $ A.toByteString str of + → case parseOnly (finishOff contentDisposition) $ cs str of Right d → return d Left err → throwError $ "malformed Content-Disposition: " - ⧺ A.toString str - ⧺ ": " - ⧺ err + ⊕ cs str + ⊕ ": " + ⊕ err contentDisposition ∷ Parser ContDispo contentDisposition - = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams) + = (ContDispo <$> (cs <$> token) ⊛ mimeParams) "contentDisposition" @@ -200,19 +199,19 @@ getContType hdrs Nothing → return Nothing Just str - → case parseOnly (finishOff MT.mimeType) $ A.toByteString str of + → case parseOnly (finishOff MT.mimeType) $ cs str of Right d → return $ Just d Left err → throwError $ "malformed Content-Type: " - ⧺ A.toString str - ⧺ ": " - ⧺ err + ⊕ cs str + ⊕ ": " + ⊕ err getBody ∷ MonadError String m ⇒ Ascii → LS.ByteString → m (LS.ByteString, LS.ByteString) {-# INLINEABLE getBody #-} -getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src +getBody (("\r\n--" ⊕) ∘ cs → boundary) src = case breakOn boundary src of (before, after) | LS.null after @@ -236,17 +235,16 @@ partToFormPair pt@(Part {..}) return (name, fd) | otherwise = throwError $ "disposition type is not \"form-data\": " - ⧺ A.toString (A.fromCIAscii $ dType ptContDispo) + ⊕ cs (dType ptContDispo) partName ∷ MonadError String m ⇒ Part → m Ascii {-# INLINEABLE partName #-} partName (Part {..}) = case lookup "name" $ dParams ptContDispo of Just name - → case A.fromText name of - Just a → return a - Nothing → throwError $ "Non-ascii part name: " - ⧺ T.unpack name + → case ca name of + Success a → return a + Failure e → throwError $ show e Nothing → throwError $ "form-data without name: " ⊕ convertSuccessVia ((⊥) ∷ Ascii) ptContDispo diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 7704727..de519da 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -19,9 +19,9 @@ import qualified Data.ByteString.Char8 as C8 import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.Convertible.Base +import Data.Convertible.Instances.Text () import Data.Maybe import Data.Text (Text) -import qualified Data.Text as T import qualified Data.Text.Encoding as T import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion @@ -151,7 +151,7 @@ updateAuthority host port req uri' = uri { uriAuthority = Just URIAuth { uriUserInfo = "" - , uriRegName = T.unpack $ CI.original host + , uriRegName = cs $ CI.original host , uriPort = cs port } } diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 2cdc45d..6c5070b 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -18,11 +18,12 @@ import Control.Monad.Trans.Maybe import qualified Data.Attoparsec.Lazy as LP import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy +import Data.Convertible.Base +import Data.Convertible.Instances.Text () import Data.List import Data.Maybe import Data.Monoid.Unicode import qualified Data.Sequence as S -import qualified Data.Text as T import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Chunk @@ -298,11 +299,11 @@ chunkWasMalformed tid eCtx e msg = let abo = mkAbortion BadRequest [("Connection", "close")] $ Just $ "chunkWasMalformed: " - ⊕ T.pack msg + ⊕ cs msg ⊕ ": " - ⊕ T.pack (intercalate ", " eCtx) + ⊕ cs (intercalate ", " eCtx) ⊕ ": " - ⊕ T.pack e + ⊕ cs e in throwTo tid abo diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 852860b..8585cea 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -165,7 +165,6 @@ import Data.Monoid.Unicode 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 @@ -555,7 +554,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 @@ -613,7 +612,7 @@ getForm limit $ "Malformed boundary: " ⊕ boundary case parseMultipartFormData b src of Right xs → return $ map (first cs) xs - Left err → abort $ mkAbortion' BadRequest $ T.pack err + 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 diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index 9feca7e..1993eb2 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -47,11 +47,11 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Collections import Data.Convertible.Base +import Data.Convertible.Instances.Text () import Data.List (intersperse, nub) import Data.Maybe import Data.Monoid import Data.Monoid.Unicode -import qualified Data.Text as T import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Abortion.Internal import Network.HTTP.Lucu.Config @@ -202,7 +202,7 @@ spawnRsrc (Resource {..}) ni@(NI {..}) toAbortion e = case fromException e of Just abortion → abortion - Nothing → mkAbortion' InternalServerError $ T.pack $ show e + Nothing → mkAbortion' InternalServerError $ cs $ show e processException ∷ SomeException → IO () processException exc diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index a1b6115..6dd47af 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -15,6 +15,8 @@ import Control.Monad.Unicode import Control.Monad.Trans import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Convertible.Base +import Data.Convertible.Instances.Text () import Data.Monoid.Unicode import Data.String import qualified Data.Text as T @@ -95,7 +97,7 @@ handleStaticDir sendContent basePath handleStaticFile sendContent path where dec8 ∷ ByteString → String - dec8 = T.unpack ∘ T.decodeUtf8 + dec8 = cs ∘ T.decodeUtf8 securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m () securityCheck pathElems diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 297ea3a..7537eaf 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -36,11 +36,12 @@ import Data.Char import Data.Collections import Data.Collections.BaseInstances () import Data.Convertible.Base +import Data.Convertible.Instances.Ascii () +import Data.Convertible.Instances.Text () import Data.Convertible.Instances.Time () import Data.Maybe import Data.Monoid.Unicode import Data.Text (Text) -import qualified Data.Text as T import Data.Time import Network.URI import Prelude hiding (last, mapM, null, reverse) @@ -73,9 +74,9 @@ splitBy isSep src -- >>> quoteStr "ab\"c" -- "\"ab\\\"c\"" quoteStr ∷ Ascii → AsciiBuilder -quoteStr str = A.toAsciiBuilder "\"" ⊕ - go (A.toByteString str) (∅) ⊕ - A.toAsciiBuilder "\"" +quoteStr str = cs ("\"" ∷ Ascii) ⊕ + go (cs str) (∅) ⊕ + cs ("\"" ∷ Ascii) where go ∷ ByteString → AsciiBuilder → AsciiBuilder go bs ab @@ -85,10 +86,10 @@ quoteStr str = A.toAsciiBuilder "\"" ⊕ → ab ⊕ b2ab x | otherwise → go (BS.tail y) - (ab ⊕ b2ab x ⊕ A.toAsciiBuilder "\\\"") + (ab ⊕ b2ab x ⊕ cs ("\\\"" ∷ Ascii)) b2ab ∷ ByteString → AsciiBuilder - b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString + b2ab = cs ∘ A.unsafeFromByteString -- |>>> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd" -- [("aaa", "bbb"), ("ccc", "ddd")] @@ -97,7 +98,7 @@ parseWWWFormURLEncoded src -- THINKME: We could gain some performance by using attoparsec -- here. | src ≡ "" = [] - | otherwise = do pairStr ← splitBy (\ c → c ≡ ';' ∨ c ≡ '&') (A.toString src) + | otherwise = do pairStr ← splitBy (\ c → c ≡ ';' ∨ c ≡ '&') (cs src) let (key, value) = break (≡ '=') pairStr return ( unescape key , unescape $ case value of @@ -116,7 +117,7 @@ parseWWWFormURLEncoded src -- "example.com" uriHost ∷ URI → Host {-# INLINE uriHost #-} -uriHost = CI.mk ∘ T.pack ∘ uriRegName ∘ fromJust ∘ uriAuthority +uriHost = CI.mk ∘ cs ∘ uriRegName ∘ fromJust ∘ uriAuthority -- |>>> uriPathSegments "http://example.com/foo/bar" -- ["foo", "bar"]