From 67f9e87a4cb7fdfe50bb3efa0b63b1628efec82c Mon Sep 17 00:00:00 2001 From: PHO Date: Mon, 19 Dec 2011 13:53:48 +0900 Subject: [PATCH] Code clean-up using convertible-text Ditz-issue: 0a2a377be55430e655ab42fdc4902fa56a058b26 --- Lucu.cabal | 2 ++ Network/HTTP/Lucu.hs | 1 - Network/HTTP/Lucu/Authentication.hs | 37 ++++++++++++------- Network/HTTP/Lucu/Config.hs | 29 ++++++++------- Network/HTTP/Lucu/ETag.hs | 45 ++++++++++++------------ Network/HTTP/Lucu/Implant/PrettyPrint.hs | 3 +- Network/HTTP/Lucu/Resource.hs | 4 +-- 7 files changed, 66 insertions(+), 55 deletions(-) diff --git a/Lucu.cabal b/Lucu.cabal index c033bb4..00f3091 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -63,7 +63,9 @@ Library collections-api == 1.0.*, collections-base-instances == 1.0.*, containers == 0.4.*, + convertible-ascii == 0.1.*, convertible-text == 0.4.*, + data-default == 0.3.*, directory == 1.1.*, filepath == 1.2.*, mtl == 2.0.*, diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index 6a827d0..a3f73be 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -59,7 +59,6 @@ module Network.HTTP.Lucu , ETag(..) , strongETag , weakETag - , parseETag -- *** MIME Type , MIMEType(..) diff --git a/Network/HTTP/Lucu/Authentication.hs b/Network/HTTP/Lucu/Authentication.hs index 29ae0e9..69223f2 100644 --- a/Network/HTTP/Lucu/Authentication.hs +++ b/Network/HTTP/Lucu/Authentication.hs @@ -1,5 +1,8 @@ {-# LANGUAGE - OverloadedStrings + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell , UnicodeSyntax #-} -- |An internal module for HTTP authentication. @@ -9,17 +12,18 @@ module Network.HTTP.Lucu.Authentication , Realm , UserID , Password - - , printAuthChallenge , authCredential ) where import Control.Monad -import Data.Ascii (Ascii) -import qualified Data.Ascii as A +import Data.Ascii (Ascii, AsciiBuilder) +import Data.Attempt import Data.Attoparsec.Char8 import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as C8 +import Data.Convertible.Base +import Data.Convertible.Instances.Ascii () +import Data.Convertible.Utils import Data.Monoid.Unicode import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils @@ -47,11 +51,18 @@ type UserID = Ascii -- |'Password' is just an 'Ascii' string. type Password = Ascii --- |Convert an 'AuthChallenge' to 'Ascii'. -printAuthChallenge ∷ AuthChallenge → Ascii -printAuthChallenge (BasicAuthChallenge realm) - = A.fromAsciiBuilder $ - A.toAsciiBuilder "Basic realm=" ⊕ quoteStr realm +instance ConvertSuccess AuthChallenge Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder) + +instance ConvertSuccess AuthChallenge AsciiBuilder where + {-# INLINE convertSuccess #-} + convertSuccess (BasicAuthChallenge realm) + = cs ("Basic realm=" ∷ Ascii) ⊕ quoteStr realm + +deriveAttempts [ ([t| AuthChallenge |], [t| Ascii |]) + , ([t| AuthChallenge |], [t| AsciiBuilder |]) + ] -- |'Parser' for an 'AuthCredential'. authCredential ∷ Parser AuthCredential @@ -72,6 +83,6 @@ authCredential base64 = inClass "a-zA-Z0-9+/=" asc ∷ C8.ByteString → Parser Ascii - asc bs = case A.fromByteString bs of - Just as → return as - Nothing → fail "Non-ascii character in auth credential" + asc bs = case ca bs of + Success as → return as + Failure _ → fail "Non-ascii character in auth credential" diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index 7a2d81f..366a63c 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -9,12 +9,12 @@ module Network.HTTP.Lucu.Config #if defined(HAVE_SSL) , SSLConfig(..) #endif - , defaultConfig ) where import Data.Ascii (Ascii) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import Data.Default import Data.Text (Text) import qualified Data.Text as T import Network @@ -105,19 +105,18 @@ data SSLConfig -- |The default configuration. Generally you can use this value as-is, -- or possibly you just want to replace the 'cnfServerSoftware' and -- 'cnfServerPort'. SSL connections are disabled by default. -defaultConfig ∷ Config -defaultConfig = Config { - cnfServerSoftware = "Lucu/1.0" - , cnfServerHost = CI.mk ∘ T.pack $ unsafePerformIO getHostName - , cnfServerPort = "http" - , cnfServerV4Addr = Just "0.0.0.0" - , cnfServerV6Addr = Just "::" +instance Default Config where + def = Config { + cnfServerSoftware = "Lucu/1.0" + , cnfServerHost = CI.mk ∘ T.pack $ unsafePerformIO getHostName + , cnfServerPort = "http" + , cnfServerV4Addr = Just "0.0.0.0" + , cnfServerV6Addr = Just "::" #if defined(HAVE_SSL) - , cnfSSLConfig = Nothing + , cnfSSLConfig = Nothing #endif - , cnfMaxPipelineDepth = 100 - , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB - , cnfDumpTooLateAbortionToStderr = True - , cnfExtToMIMEType = defaultExtensionMap - } --- FIXME: use data-default. + , cnfMaxPipelineDepth = 100 + , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB + , cnfDumpTooLateAbortionToStderr = True + , cnfExtToMIMEType = defaultExtensionMap + } diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs index 08c1060..3ebfc1d 100644 --- a/Network/HTTP/Lucu/ETag.hs +++ b/Network/HTTP/Lucu/ETag.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveDataTypeable + , FlexibleInstances + , MultiParamTypeClasses , OverloadedStrings , RecordWildCards , TemplateHaskell @@ -8,8 +10,6 @@ -- |An internal module for entity tags. module Network.HTTP.Lucu.ETag ( ETag(..) - , parseETag - , printETag , strongETag , weakETag @@ -20,13 +20,14 @@ module Network.HTTP.Lucu.ETag import Control.Applicative import Control.Monad import Data.Ascii (Ascii, AsciiBuilder) -import qualified Data.Ascii as A import Data.Attoparsec.Char8 +import Data.Convertible.Base +import Data.Convertible.Instances.Ascii () +import Data.Convertible.Utils import Data.Data import Data.Monoid.Unicode import Language.Haskell.TH.Syntax import Network.HTTP.Lucu.OrphanInstances () -import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http hiding (token) import Network.HTTP.Lucu.Utils import Prelude.Unicode @@ -50,26 +51,24 @@ instance Lift ETag where } |] --- |Convert an 'ETag' to an 'AsciiBuilder'. -printETag ∷ ETag → AsciiBuilder -{-# INLINEABLE printETag #-} -printETag et - = ( if etagIsWeak et then - A.toAsciiBuilder "W/" - else - (∅) - ) - ⊕ - quoteStr (etagToken et) +instance ConvertSuccess ETag Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder) --- |Parse 'Etag' from an 'Ascii'. This functions throws an exception --- for parse error. -parseETag ∷ Ascii → ETag -{-# INLINEABLE parseETag #-} -parseETag str - = case parseOnly (finishOff eTag) $ A.toByteString str of - Right et → et - Left err → error ("unparsable ETag: " ⧺ A.toString str ⧺ ": " ⧺ err) +instance ConvertSuccess ETag AsciiBuilder where + {-# INLINE convertSuccess #-} + convertSuccess (ETag {..}) + = ( if etagIsWeak then + cs ("W/" ∷ Ascii) + else + (∅) + ) + ⊕ + quoteStr etagToken + +deriveAttempts [ ([t| ETag |], [t| Ascii |]) + , ([t| ETag |], [t| AsciiBuilder |]) + ] -- |This is equivalent to @'ETag' 'False'@. If you want to generate an -- ETag from a file, try using diff --git a/Network/HTTP/Lucu/Implant/PrettyPrint.hs b/Network/HTTP/Lucu/Implant/PrettyPrint.hs index f5376f1..51c2de1 100644 --- a/Network/HTTP/Lucu/Implant/PrettyPrint.hs +++ b/Network/HTTP/Lucu/Implant/PrettyPrint.hs @@ -19,6 +19,7 @@ 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.List (intersperse) import Data.Monoid import Data.Ratio @@ -68,7 +69,7 @@ header i@(Input {..}) ] where eTagToDoc ∷ ETag → Doc - eTagToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printETag + eTagToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ cs mimeTypeToDoc ∷ MIMEType → Doc mimeTypeToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 5c45ace..6f3ecce 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -380,7 +380,7 @@ foundETag tag when (method ≡ GET ∨ method ≡ HEAD) $ setHeader "ETag" $ A.fromAsciiBuilder - $ printETag tag + $ cs tag when (method ≡ POST) $ abort $ mkAbortion' InternalServerError @@ -670,7 +670,7 @@ setContentEncoding codings -- |@'setWWWAuthenticate' challenge@ declares the response header -- \"WWW-Authenticate\" as @challenge@. setWWWAuthenticate ∷ AuthChallenge → Rsrc () -setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge +setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ cs -- |Write a chunk in 'Strict.ByteString' to the response body. You -- must first declare the response header \"Content-Type\" before -- 2.40.0