From: PHO Date: Mon, 19 Dec 2011 12:18:01 +0000 (+0900) Subject: Merge branch 'convertible' X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=commitdiff_plain;h=5f2ef377345fc47aabc63c1325df82c1cd9da9ed;hp=313924e79d4ed48d3efb9f2530a48305fdd68c4b Merge branch 'convertible' --- 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/Lucu.cabal b/Lucu.cabal index a35fb08..00f3091 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -51,7 +51,8 @@ Flag ssl Library Build-Depends: ascii == 0.0.*, - attoparsec == 0.9.*, + attempt == 0.3.*, + attoparsec == 0.10.*, base == 4.*, base-unicode-symbols == 0.2.*, base64-bytestring == 0.1.*, @@ -62,6 +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.*, @@ -70,10 +74,11 @@ Library stm == 2.2.*, stringsearch == 0.3.*, syb == 0.3.*, + tagged == 0.2.*, template-haskell == 2.5.*, text == 0.11.*, time == 1.2.*, - time-http == 0.2.*, + time-http == 0.4.*, transformers == 0.2.* if flag(ssl) diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index 6a827d0..876064c 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -59,12 +59,10 @@ module Network.HTTP.Lucu , ETag(..) , strongETag , weakETag - , parseETag -- *** MIME Type , MIMEType(..) , MIMEParams - , parseMIMEType , mimeType -- *** Authentication 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..d1afdc0 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -9,14 +9,15 @@ 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.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 @@ -105,19 +106,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 ∘ cs $ 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/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index e106774..c5ae6f5 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings , RecordWildCards + , ScopedTypeVariables , TypeOperators , UnicodeSyntax #-} @@ -12,8 +13,9 @@ module Network.HTTP.Lucu.DefaultPage where import Blaze.ByteString.Builder (Builder) import Data.Ascii (Ascii) -import qualified Data.Ascii as A import qualified Data.CaseInsensitive as CI +import Data.Convertible.Base +import Data.Convertible.Utils import Data.Maybe import Data.Monoid.Unicode import Data.Text (Text) @@ -38,21 +40,24 @@ 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 hr - address $ do toHtml $ A.toText cnfServerSoftware + address $ do toHtml (cs cnfServerSoftware ∷ Text) unsafeByteString " at " toHtml $ CI.original cnfServerHost + where + scText ∷ sc → Text + scText = convertSuccessVia ((⊥) ∷ Ascii) ∘ fromStatusCode defaultMessage ∷ Maybe Request → Response → Html {-# INLINEABLE defaultMessage #-} @@ -123,7 +128,7 @@ defaultMessage req res@(Response {..}) path = toHtml ∘ uriPath ∘ reqURI $ fromJust req loc ∷ Text - loc = A.toText ∘ fromJust $ getHeader "Location" res + loc = cs ∘ fromJust $ getHeader "Location" res hr ∷ Html {-# INLINE hr #-} diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs index 08c1060..6d09aee 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,9 +10,6 @@ -- |An internal module for entity tags. module Network.HTTP.Lucu.ETag ( ETag(..) - , parseETag - , printETag - , strongETag , weakETag , eTag @@ -20,13 +19,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 +50,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) + +instance ConvertSuccess ETag AsciiBuilder where + {-# INLINE convertSuccess #-} + convertSuccess (ETag {..}) + = ( if etagIsWeak then + cs ("W/" ∷ Ascii) + else + (∅) + ) + ⊕ + quoteStr etagToken --- |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) +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/Headers.hs b/Network/HTTP/Lucu/Headers.hs index 242d191..f0e6ad8 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -12,9 +12,7 @@ module Network.HTTP.Lucu.Headers ( Headers , HasHeaders(..) - , headers - , printHeaders ) where import Control.Applicative hiding (empty) @@ -22,8 +20,11 @@ import Control.Applicative.Unicode hiding ((∅)) import Control.Monad import Data.Ascii (Ascii, AsciiBuilder, CIAscii) import qualified Data.Ascii as A -import Data.Attoparsec.Char8 as P +import Data.Attoparsec.Char8 import qualified Data.Collections.Newtype.TH as C +import Data.Convertible.Base +import Data.Convertible.Instances.Ascii () +import Data.Convertible.Utils import Data.List (intersperse) import qualified Data.Map as M (Map) import Data.Collections @@ -56,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 #-} @@ -105,6 +106,27 @@ merge a b {-# INLINE nullA #-} nullA = null ∘ A.toByteString +instance ConvertSuccess Headers Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder) + +instance ConvertSuccess Headers AsciiBuilder where + {-# 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) ⊕ + cs value ⊕ + cs ("\x0D\x0A" ∷ Ascii) + +deriveAttempts [ ([t| Headers |], [t| Ascii |]) + , ([t| Headers |], [t| AsciiBuilder |]) + ] + {- message-header = field-name ":" [ field-value ] field-name = token @@ -118,12 +140,12 @@ merge a b -} headers ∷ Parser Headers {-# INLINEABLE headers #-} -headers = do xs ← P.many header +headers = do xs ← many header crlf 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 @@ -139,19 +161,7 @@ headers = do xs ← P.many header joinValues ∷ [Ascii] → Ascii {-# INLINE joinValues #-} - joinValues = A.fromAsciiBuilder + joinValues = cs ∘ mconcat - ∘ intersperse (A.toAsciiBuilder "\x20") - ∘ (A.toAsciiBuilder <$>) - -printHeaders ∷ Headers → AsciiBuilder -printHeaders (Headers m) - = mconcat (printHeader <$> fromFoldable m) ⊕ - A.toAsciiBuilder "\x0D\x0A" - where - printHeader ∷ (CIAscii, Ascii) → AsciiBuilder - printHeader (name, value) - = A.toAsciiBuilder (A.fromCIAscii name) ⊕ - A.toAsciiBuilder ": " ⊕ - A.toAsciiBuilder value ⊕ - A.toAsciiBuilder "\x0D\x0A" + ∘ intersperse (cs ("\x20" ∷ Ascii) ∷ AsciiBuilder) + ∘ (cs <$>) diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs index 4466f1e..8890427 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -1,21 +1,26 @@ {-# LANGUAGE - OverloadedStrings + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell , UnicodeSyntax #-} -- |An internal module for HTTP version numbers. module Network.HTTP.Lucu.HttpVersion ( HttpVersion(..) - , printHttpVersion , httpVersion ) where import Control.Applicative import Control.Applicative.Unicode -import Data.Ascii (AsciiBuilder) -import qualified Data.Ascii as A +import Data.Ascii (Ascii, AsciiBuilder) import Data.Attoparsec.Char8 +import Data.Convertible.Base +import Data.Convertible.Instances.Ascii () +import Data.Convertible.Utils import Data.Monoid.Unicode import Prelude hiding (min) +import Prelude.Unicode -- |An HTTP version consists of major and minor versions. data HttpVersion @@ -30,19 +35,27 @@ instance Ord HttpVersion where | minA < minB = LT | otherwise = EQ --- |Convert an 'HttpVersion' to 'AsciiBuilder'. -printHttpVersion ∷ HttpVersion → AsciiBuilder -printHttpVersion v - = case v of - -- Optimisation for special cases. - HttpVersion 1 0 → A.toAsciiBuilder "HTTP/1.0" - HttpVersion 1 1 → A.toAsciiBuilder "HTTP/1.1" - -- General (but almost never stumbling) cases. - HttpVersion maj min - → A.toAsciiBuilder "HTTP/" ⊕ - A.toAsciiBuilder (A.unsafeFromString $ show maj) ⊕ - A.toAsciiBuilder "." ⊕ - A.toAsciiBuilder (A.unsafeFromString $ show min) +instance ConvertSuccess HttpVersion Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder) + +instance ConvertSuccess HttpVersion AsciiBuilder where + {-# INLINE convertSuccess #-} + convertSuccess v + = case v of + -- Optimisation for special cases. + HttpVersion 1 0 → cs ("HTTP/1.0" ∷ Ascii) + HttpVersion 1 1 → cs ("HTTP/1.1" ∷ Ascii) + -- General (but almost never occuring) cases. + HttpVersion maj min + → cs ("HTTP/" ∷ Ascii) ⊕ + convertUnsafe (show maj) ⊕ + cs ("." ∷ Ascii) ⊕ + convertUnsafe (show min) + +deriveAttempts [ ([t| HttpVersion |], [t| Ascii |]) + , ([t| HttpVersion |], [t| AsciiBuilder |]) + ] -- |'Parser' for an 'HttpVersion'. httpVersion ∷ Parser HttpVersion diff --git a/Network/HTTP/Lucu/Implant.hs b/Network/HTTP/Lucu/Implant.hs index 90c83f2..58e2b2e 100644 --- a/Network/HTTP/Lucu/Implant.hs +++ b/Network/HTTP/Lucu/Implant.hs @@ -17,8 +17,9 @@ module Network.HTTP.Lucu.Implant where import Codec.Compression.GZip import Control.Applicative -import qualified Data.Ascii as A import qualified Data.ByteString.Lazy as L +import Data.Convertible.Base +import Data.Convertible.Instances.Ascii () import Data.Digest.Pure.SHA import Data.Maybe import Data.Time @@ -87,5 +88,5 @@ guessType = guessTypeByFileName defaultExtensionMap mkETagFromInput ∷ L.ByteString → ETag mkETagFromInput input - = strongETag $ A.unsafeFromString + = strongETag $ convertUnsafe $ "SHA-1:" ⧺ showDigest (sha1 input) diff --git a/Network/HTTP/Lucu/Implant/PrettyPrint.hs b/Network/HTTP/Lucu/Implant/PrettyPrint.hs index f5376f1..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 @@ -14,11 +16,12 @@ module Network.HTTP.Lucu.Implant.PrettyPrint where import Codec.Compression.GZip import Control.Monad -import Data.Ascii (CIAscii) -import qualified Data.Ascii as A +import Data.Ascii (Ascii, CIAscii) 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 import Data.Ratio @@ -59,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 ∘ A.toString ∘ A.fromAsciiBuilder ∘ printETag - - 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/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 41c74a3..d36c4d1 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -33,10 +33,12 @@ import Control.Applicative import Control.Concurrent.STM import Data.Ascii (Ascii) import Data.ByteString (ByteString) +import Data.Convertible.Base import Data.Monoid.Unicode +import Data.Proxy import Data.Sequence (Seq) import Data.Time -import qualified Data.Time.HTTP as HTTP +import Data.Time.Format.HTTP import Data.Typeable import Network.Socket import Network.HTTP.Lucu.Config @@ -49,6 +51,7 @@ import Network.HTTP.Lucu.Utils #if defined(HAVE_SSL) import OpenSSL.X509 #endif +import Prelude.Unicode class Typeable i ⇒ Interaction i where toInteraction ∷ i → SomeInteraction @@ -244,7 +247,9 @@ mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath type InteractionQueue = TVar (Seq SomeInteraction) mkInteractionQueue ∷ IO InteractionQueue +{-# INLINE mkInteractionQueue #-} mkInteractionQueue = newTVarIO (∅) getCurrentDate ∷ IO Ascii -getCurrentDate = HTTP.toAscii <$> getCurrentTime +{-# INLINE getCurrentDate #-} +getCurrentDate = flip proxy http ∘ cs <$> getCurrentTime diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs index 89b2bfd..6f9eb7e 100644 --- a/Network/HTTP/Lucu/MIMEParams.hs +++ b/Network/HTTP/Lucu/MIMEParams.hs @@ -16,7 +16,6 @@ -- (). module Network.HTTP.Lucu.MIMEParams ( MIMEParams - , printMIMEParams , mimeParams ) where @@ -25,13 +24,16 @@ import Control.Monad hiding (mapM) import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii, AsciiBuilder) import qualified Data.Ascii as A -import Data.Attoparsec.Char8 as P +import Data.Attoparsec.Char8 import Data.Bits import qualified Data.ByteString.Char8 as BS import Data.Char import Data.Collections import Data.Collections.BaseInstances () import qualified Data.Collections.Newtype.TH as C +import Data.Convertible.Base +import Data.Convertible.Instances.Ascii () +import Data.Convertible.Utils import qualified Data.Map as M (Map) import Data.Monoid.Unicode import Data.Sequence (Seq) @@ -55,14 +57,17 @@ C.derive [d| instance Unfoldable MIMEParams (CIAscii, Text) instance SortingCollection MIMEParams (CIAscii, Text) |] --- |Convert MIME parameter values to an 'AsciiBuilder'. -printMIMEParams ∷ MIMEParams → AsciiBuilder -{-# INLINEABLE printMIMEParams #-} -printMIMEParams = foldl' f (∅) - where - f ∷ AsciiBuilder → (CIAscii, Text) → AsciiBuilder - {-# INLINE f #-} - f ab (k, v) = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v +instance ConvertSuccess MIMEParams Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder) + +instance ConvertSuccess MIMEParams AsciiBuilder where + {-# INLINEABLE convertSuccess #-} + convertSuccess = foldl' f (∅) + where + f ∷ AsciiBuilder → (CIAscii, Text) → AsciiBuilder + {-# INLINE f #-} + f ab (k, v) = ab ⊕ cs ("; " ∷ Ascii) ⊕ printPair k v printPair ∷ CIAscii → Text → AsciiBuilder {-# INLINEABLE printPair #-} @@ -75,19 +80,19 @@ printPair name value printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder {-# INLINEABLE printPairInUTF8 #-} printPairInUTF8 name value - = A.toAsciiBuilder (A.fromCIAscii name) ⊕ - A.toAsciiBuilder "*=utf-8''" ⊕ + = cs name ⊕ + cs ("*=utf-8''" ∷ Ascii) ⊕ escapeUnsafeChars (encodeUtf8 value) (∅) printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder {-# INLINEABLE printPairInAscii #-} printPairInAscii name value - = A.toAsciiBuilder (A.fromCIAscii name) ⊕ - A.toAsciiBuilder "=" ⊕ - if BS.any ((¬) ∘ isToken) (A.toByteString value) then + = cs name ⊕ + cs ("=" ∷ Ascii) ⊕ + if BS.any ((¬) ∘ isToken) (cs value) then quoteStr value else - A.toAsciiBuilder value + cs value escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder {-# INLINEABLE escapeUnsafeChars #-} @@ -96,15 +101,15 @@ escapeUnsafeChars bs b Nothing → b Just (c, bs') | isToken c → escapeUnsafeChars bs' $ - b ⊕ A.toAsciiBuilder (A.unsafeFromString [c]) + b ⊕ cs (A.unsafeFromString [c]) | otherwise → escapeUnsafeChars bs' $ b ⊕ toHex (fromIntegral $ fromEnum c) toHex ∷ Word8 → AsciiBuilder {-# INLINEABLE toHex #-} -toHex o = A.toAsciiBuilder "%" ⊕ - A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8) - , toHex' (o .&. 0x0F) ]) +toHex o = cs ("%" ∷ Ascii) ⊕ + cs (A.unsafeFromString [ toHex' (o `shiftR` 8) + , toHex' (o .&. 0x0F) ]) where toHex' ∷ Word8 → Char {-# INLINEABLE toHex' #-} @@ -114,6 +119,10 @@ toHex o = A.toAsciiBuilder "%" ⊕ | otherwise = toEnum $ fromIntegral $ fromEnum 'A' + fromIntegral (h - 0x0A) +deriveAttempts [ ([t| MIMEParams |], [t| Ascii |]) + , ([t| MIMEParams |], [t| AsciiBuilder |]) + ] + data ExtendedParam = InitialEncodedParam { epName ∷ !CIAscii @@ -139,7 +148,7 @@ section ep = epSection ep -- |'Parser' for MIME parameter values. mimeParams ∷ Parser MIMEParams {-# INLINEABLE mimeParams #-} -mimeParams = decodeParams =≪ P.many (try paramP) +mimeParams = decodeParams =≪ many (try paramP) paramP ∷ Parser ExtendedParam paramP = do skipMany lws @@ -159,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) @@ -181,12 +190,12 @@ 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 {-# INLINE encodedPayload #-} -encodedPayload = BS.concat <$> P.many (hexChar <|> rawChars) +encodedPayload = BS.concat <$> many (hexChar <|> rawChars) hexChar ∷ Parser BS.ByteString {-# INLINEABLE hexChar #-} @@ -248,7 +257,7 @@ sortBySection = flip go (∅) → fail (concat [ "Duplicate section " , show $ section x , " for parameter '" - , A.toString $ A.fromCIAscii $ epName x + , cs $ epName x , "'" ]) @@ -271,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 , "'" ]) @@ -287,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 @@ -311,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 @@ -331,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 2861d26..250fdbf 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,18 +11,16 @@ -- (). module Network.HTTP.Lucu.MIMEType ( MIMEType(..) - - , parseMIMEType - , printMIMEType - , mimeType , mimeTypeList ) 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 import Data.Monoid.Unicode import Data.Typeable import Language.Haskell.TH.Syntax @@ -48,31 +48,37 @@ 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) ⊕ - printMIMEParams 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 {-# 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 d77c976..cd178de 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -17,9 +17,11 @@ 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 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 @@ -103,7 +104,7 @@ parseExtMap src "pair" ext ∷ Parser Text - ext = (decodeUtf8 <$> P.takeWhile1 isAlphaNum) + ext = (decodeUtf8 <$> takeWhile1 isAlphaNum) "ext" @@ -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/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..2d1b347 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,20 +22,22 @@ 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 qualified Data.Ascii as A +import Data.Ascii (Ascii, CIAscii, AsciiBuilder) +import Data.Attempt import Data.Attoparsec import qualified Data.Attoparsec.Lazy as LP 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 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) @@ -69,12 +74,18 @@ data ContDispo , dParams ∷ !MIMEParams } -printContDispo ∷ ContDispo → Ascii -printContDispo d - = A.fromAsciiBuilder - ( A.toAsciiBuilder (A.fromCIAscii $ dType d) - ⊕ - printMIMEParams (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 @@ -124,7 +135,7 @@ prologue ∷ Ascii → Parser () prologue boundary = ( (string "--" "prefix") *> - (string (A.toByteString boundary) "boundary") + (string (cs boundary) "boundary") *> pure () ) @@ -168,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" @@ -188,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 @@ -224,20 +235,19 @@ 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: " - ⧺ A.toString (printContDispo ptContDispo) + ⊕ convertSuccessVia ((⊥) ∷ Ascii) ptContDispo partFileName ∷ Part → Maybe Text partFileName (ptContDispo → ContDispo {..}) diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs index e59f460..6758d40 100644 --- a/Network/HTTP/Lucu/Parser/Http.hs +++ b/Network/HTTP/Lucu/Parser/Http.hs @@ -30,8 +30,7 @@ import Control.Applicative import Control.Monad import Data.Ascii (Ascii) import qualified Data.Ascii as A -import Data.Attoparsec.Char8 as P hiding (scan) -import qualified Data.Attoparsec.FastSet as FS +import Data.Attoparsec.Char8 import qualified Data.ByteString.Char8 as BS import Network.HTTP.Lucu.Parser import Prelude.Unicode @@ -53,10 +52,7 @@ isText = (¬) ∘ isCtl -- separators. isSeparator ∷ Char → Bool {-# INLINE isSeparator #-} -isSeparator = flip FS.memberChar set - where - {-# NOINLINE set #-} - set = FS.charClass "()<>@,;:\\\"/[]?={}\x20\x09" +isSeparator = inClass "()<>@,;:\\\"/[]?={}\x20\x09" -- |@'isChar' c@ returns 'True' iff @c <= 0x7f@. isChar ∷ Char → Bool @@ -126,7 +122,7 @@ separators = (A.unsafeFromByteString <$> takeWhile1 isSeparator) quotedStr ∷ Parser Ascii {-# INLINEABLE quotedStr #-} quotedStr = do void $ char '"' - xs ← P.many (qdtext <|> quotedPair) + xs ← many (qdtext <|> quotedPair) void $ char '"' return ∘ A.unsafeFromByteString $ BS.pack xs 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/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 1284f2b..de519da 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -18,9 +18,10 @@ import qualified Data.Ascii as A 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 @@ -137,7 +138,7 @@ examineAuthority localHost localPort parseHost ∷ Ascii → (CI Text, Ascii) parseHost hp - = let (h, p) = C8.break (≡ ':') $ A.toByteString hp + = let (h, p) = C8.break (≡ ':') $ cs hp -- FIXME: should decode punycode here. hText = CI.mk $ T.decodeUtf8 h pAscii = A.unsafeFromByteString p @@ -150,8 +151,8 @@ updateAuthority host port req uri' = uri { uriAuthority = Just URIAuth { uriUserInfo = "" - , uriRegName = T.unpack $ CI.original host - , uriPort = A.toString port + , uriRegName = cs $ CI.original host + , uriPort = cs port } } in @@ -179,7 +180,7 @@ examineHeaders | otherwise → setStatus NotImplemented - case A.toByteString <$> getHeader "Content-Length" req of + case cs <$> getHeader "Content-Length" req of Nothing → return () Just value → case C8.readInt value of Just (len, garbage) 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 652c5f7..8585cea 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP , BangPatterns + , FlexibleContexts , GeneralizedNewtypeDeriving , DoAndIfThenElse , OverloadedStrings @@ -147,21 +148,25 @@ import Control.Arrow import Control.Monad import Control.Monad.IO.Class import Control.Monad.Unicode -import Data.Ascii (Ascii, CIAscii) -import qualified Data.Ascii as A +import Data.Ascii (Ascii, CIAscii, AsciiBuilder) +import Data.Attempt import qualified Data.Attoparsec.Char8 as P import Data.ByteString (ByteString) 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 import Data.Monoid.Unicode +import Data.Proxy +import Data.Tagged import Data.Text (Text) -import qualified Data.Text as T import Data.Time -import qualified Data.Time.HTTP as HTTP +import Data.Time.Format.HTTP import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Authentication import Network.HTTP.Lucu.Config @@ -230,8 +235,7 @@ getQueryForm = parse' <$> getRequestURI where parse' = map toPairWithFormData ∘ parseWWWFormURLEncoded ∘ - fromJust ∘ - A.fromChars ∘ + convertUnsafe ∘ drop 1 ∘ uriQuery @@ -261,10 +265,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 @@ -289,10 +293,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) @@ -313,10 +317,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'. @@ -327,7 +331,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 @@ -351,7 +355,9 @@ foundEntity tag timeStamp method ← getMethod when (method ≡ GET ∨ method ≡ HEAD) - $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) + $ setHeader "Last-Modified" + $ flip proxy http + $ cs timeStamp when (method ≡ POST) $ abort $ mkAbortion' InternalServerError @@ -373,8 +379,7 @@ foundETag tag method ← getMethod when (method ≡ GET ∨ method ≡ HEAD) $ setHeader "ETag" - $ A.fromAsciiBuilder - $ printETag tag + $ cs tag when (method ≡ POST) $ abort $ mkAbortion' InternalServerError @@ -389,17 +394,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 @@ -417,15 +422,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 @@ -445,7 +450,9 @@ foundTimeStamp timeStamp method ← getMethod when (method ≡ GET ∨ method ≡ HEAD) - $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) + $ setHeader "Last-Modified" + $ flip proxy http + $ cs timeStamp when (method ≡ POST) $ abort $ mkAbortion' InternalServerError @@ -459,28 +466,28 @@ foundTimeStamp timeStamp ifModSince ← getHeader "If-Modified-Since" case ifModSince of - Just str → case HTTP.fromAscii str of - Right lastTime + Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of + Just lastTime → when (timeStamp ≤ lastTime) $ abort $ mkAbortion' statusForIfModSince - $ "The entity has not been modified since " ⊕ A.toText str - Left e + $ "The entity has not been modified since " ⊕ cs str + Nothing → abort $ mkAbortion' BadRequest - $ "Malformed If-Modified-Since: " ⊕ T.pack e + $ "Malformed If-Modified-Since: " ⊕ cs str Nothing → return () ifUnmodSince ← getHeader "If-Unmodified-Since" case ifUnmodSince of - Just str → case HTTP.fromAscii str of - Right lastTime + Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of + Just lastTime → when (timeStamp > lastTime) $ abort $ mkAbortion' PreconditionFailed - $ "The entity has not been modified since " ⊕ A.toText str - Left e + $ "The entity has not been modified since " ⊕ cs str + Nothing → abort $ mkAbortion' BadRequest - $ "Malformed If-Unmodified-Since: " ⊕ T.pack e + $ "Malformed If-Unmodified-Since: " ⊕ cs str Nothing → return () driftTo ReceivingBody @@ -547,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 @@ -579,10 +586,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) @@ -590,9 +596,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 @@ -600,13 +606,13 @@ 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 - Left err → abort $ mkAbortion' BadRequest $ T.pack err + Right xs → return $ map (first cs) xs + 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 @@ -616,10 +622,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 @@ -627,17 +632,16 @@ 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. setLocation ∷ URI → Rsrc () setLocation uri - = case A.fromChars uriStr of - Just a → setHeader "Location" a - Nothing → abort $ mkAbortion' InternalServerError - $ "Malformed URI: " ⊕ T.pack uriStr + = case ca uriStr of + Success a → setHeader "Location" a + Failure e → abort $ mkAbortion' InternalServerError + $ cs (show e) where uriStr = uriToString id uri "" @@ -652,17 +656,18 @@ setContentEncoding codings _ → abort $ mkAbortion' InternalServerError "setContentEncoding: Unknown HTTP version" setHeader "Content-Encoding" - $ A.fromAsciiBuilder + $ cs $ mconcat - $ intersperse (A.toAsciiBuilder ", ") + $ intersperse (cs (", " ∷ Ascii)) $ map tr codings where - toAB = A.toAsciiBuilder ∘ A.fromCIAscii + toAB ∷ ConvertSuccess α AsciiBuilder ⇒ α → AsciiBuilder + toAB = cs -- |@'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 diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index e5c38e7..1993eb2 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -42,16 +42,16 @@ import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Reader (ReaderT, runReaderT, ask) import Control.Monad.Unicode -import Data.Ascii (Ascii, CIAscii) -import qualified Data.Ascii as A +import Data.Ascii (Ascii, CIAscii, AsciiBuilder) 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 @@ -180,10 +180,10 @@ spawnRsrc (Resource {..}) ni@(NI {..}) notAllowed ∷ Rsrc () notAllowed = do setStatus MethodNotAllowed setHeader "Allow" - $ A.fromAsciiBuilder + $ cs $ mconcat - $ intersperse (A.toAsciiBuilder ", ") - $ map A.toAsciiBuilder allowedMethods + $ intersperse (cs (", " ∷ Ascii) ∷ AsciiBuilder) + $ map cs allowedMethods allowedMethods ∷ [Ascii] allowedMethods = nub $ concat [ methods resGet ["GET"] @@ -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/Response.hs b/Network/HTTP/Lucu/Response.hs index c18819f..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,10 @@ 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 import Data.Monoid.Unicode import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion @@ -39,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 @@ -55,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 @@ -82,16 +97,6 @@ resCanHaveBody (Response {..}) | resStatus ≈ NotModified = False | otherwise = True --- |Convert a 'Response' to 'AsciiBuilder'. -printResponse ∷ Response → AsciiBuilder -{-# INLINEABLE printResponse #-} -printResponse (Response {..}) - = printHttpVersion resVersion ⊕ - A.toAsciiBuilder " " ⊕ - printStatusCode resStatus ⊕ - A.toAsciiBuilder "\x0D\x0A" ⊕ - printHeaders 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/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/StatusCode.hs b/Network/HTTP/Lucu/StatusCode.hs index 2dd3863..8f3e225 100644 --- a/Network/HTTP/Lucu/StatusCode.hs +++ b/Network/HTTP/Lucu/StatusCode.hs @@ -1,5 +1,6 @@ {-# LANGUAGE - QuasiQuotes + OverloadedStrings + , QuasiQuotes #-} -- |Definition of HTTP status code. -- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named status diff --git a/Network/HTTP/Lucu/StatusCode/Internal.hs b/Network/HTTP/Lucu/StatusCode/Internal.hs index d6e892b..2121037 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 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.Ascii () +import Data.Convertible.Utils import Data.List import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax @@ -37,7 +43,7 @@ class Show sc ⇒ StatusCode sc where numericCode ∷ sc → Int -- |Return the combination of 3-digit integer and reason phrase -- for this status e.g. @200 OK@ - textualStatus ∷ sc → Ascii + textualStatus ∷ sc → AsciiBuilder -- |Wrap the status code into 'SomeStatusCode'. fromStatusCode ∷ sc → SomeStatusCode fromStatusCode = SomeStatusCode @@ -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 = 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 @@ -91,17 +113,17 @@ instance StatusCode SomeStatusCode where -- data OK = OK deriving ('Show') -- instance OK where -- 'numericCode' _ = 200 --- 'textualStatus' _ = 'A.unsafeFromString' \"200 OK\" +-- 'textualStatus' _ = 'cs' (\"200 OK\" ∷ Ascii) -- -- data BadRequest = BadRequest deriving ('Show') -- instance BadRequest where -- 'numericCode' _ = 400 --- 'textualStatus' _ = 'A.unsafeFromString' \"400 Bad Request\" +-- 'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii) -- -- data MethodNotAllowed = MethodNotAllowed deriving ('Show') -- instance MethodNotAllowed where -- 'numericCode' _ = 405 --- 'textualStatus' _ = 'A.unsafeFromString' \"405 Method Not Allowed\" +-- 'textualStatus' _ = 'cs' (\"405 Method Not Allowed\" ∷ Ascii) -- @ statusCodes ∷ QuasiQuoter statusCodes = QuasiQuoter { @@ -144,7 +166,7 @@ parseStatusCodes src "pair" word ∷ Parser Ascii - word = A.unsafeFromByteString <$> P.takeWhile1 isAlpha_ascii + word = A.unsafeFromByteString <$> takeWhile1 isAlpha_ascii statusDecl ∷ (Int, [Ascii]) → Q [Dec] statusDecl (num, phrase) @@ -153,7 +175,7 @@ statusDecl (num, phrase) return (a:bs) where name ∷ Name - name = mkName $ concatMap A.toString phrase + name = mkName $ concatMap cs phrase dataDecl ∷ Q Dec dataDecl = dataD (cxt []) name [] [con] [''Show] @@ -174,8 +196,8 @@ statusDecl (num, phrase) con = return $ NormalC name [] txt ∷ Q Exp - txt = [| A.unsafeFromString $(lift txt') |] + txt = [| cs ($(lift txt') ∷ Ascii) |] txt' ∷ String txt' = concat $ intersperse "\x20" - $ show num : map A.toString phrase + $ show num : map cs phrase diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 9abaf1e..7537eaf 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -35,18 +35,18 @@ import qualified Data.CaseInsensitive as CI 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.Ratio import Data.Text (Text) -import qualified Data.Text as T import Data.Time -import Data.Time.Clock.POSIX import Network.URI import Prelude hiding (last, mapM, null, reverse) import Prelude.Unicode import System.Directory -import System.Time (ClockTime(..)) -- |'Host' represents an IP address or a host name in an URI -- authority. @@ -74,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 @@ -86,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")] @@ -98,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 @@ -117,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"] @@ -166,9 +166,4 @@ mapM = flip foldrM empty ∘ (flip ((<$>) ∘ flip insert) ∘) -- |Get the modification time of a given file. getLastModified ∷ FilePath → IO UTCTime -getLastModified = (clockTimeToUTC <$>) ∘ getModificationTime - where - clockTimeToUTC ∷ ClockTime → UTCTime - clockTimeToUTC (TOD sec picoSec) - = posixSecondsToUTCTime ∘ fromRational - $ sec % 1 + picoSec % (1000 ⋅ 1000 ⋅ 1000 ⋅ 1000) +getLastModified = (cs <$>) ∘ getModificationTime diff --git a/bugs/issue-0a2a377be55430e655ab42fdc4902fa56a058b26.yaml b/bugs/issue-0a2a377be55430e655ab42fdc4902fa56a058b26.yaml index e731191..79fa84b 100644 --- a/bugs/issue-0a2a377be55430e655ab42fdc4902fa56a058b26.yaml +++ b/bugs/issue-0a2a377be55430e655ab42fdc4902fa56a058b26.yaml @@ -1,11 +1,11 @@ --- !ditz.rubyforge.org,2008-03-06/issue -title: Use convertible whenever appropriate. +title: Use convertible wherever appropriate. desc: "" type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :unstarted +status: :in_progress disposition: creation_time: 2011-12-14 14:07:41.367770 Z references: [] @@ -16,4 +16,12 @@ log_events: - PHO - created - "" +- - 2011-12-15 00:08:57.500763 Z + - PHO + - edited title + - "" +- - 2011-12-15 12:42:17.264054 Z + - PHO + - changed status from unstarted to in_progress + - "" git_branch: diff --git a/bugs/issue-e6ec5a54d14cad8f79c456e23e92770fbbd3577e.yaml b/bugs/issue-e6ec5a54d14cad8f79c456e23e92770fbbd3577e.yaml new file mode 100644 index 0000000..601c7f4 --- /dev/null +++ b/bugs/issue-e6ec5a54d14cad8f79c456e23e92770fbbd3577e.yaml @@ -0,0 +1,19 @@ +--- !ditz.rubyforge.org,2008-03-06/issue +title: Rsrc Monad should be parameterised by phantom types (e.g. Rsrc GET a) to reduce the chance of runtime errors. +desc: "" +type: :task +component: Lucu +release: Lucu-1.0 +reporter: PHO +status: :unstarted +disposition: +creation_time: 2011-12-16 10:11:08.635552 Z +references: [] + +id: e6ec5a54d14cad8f79c456e23e92770fbbd3577e +log_events: +- - 2011-12-16 10:11:09.535825 Z + - PHO + - created + - "" +git_branch: diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index 2d240e8..fb1c8ac 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -7,13 +7,14 @@ import Control.Applicative import Control.Monad.Unicode import qualified Data.ByteString.Lazy.Char8 as Lazy import qualified Data.Collections as C +import Data.Default import Data.Monoid.Unicode import Network import Network.HTTP.Lucu import Prelude.Unicode main ∷ IO () -main = let config = defaultConfig { cnfServerPort = "9999" } +main = let config = def { cnfServerPort = "9999" } mapper = resourceMap resources ⊕ resourceMap fallbacks resources ∷ ResourceTree resources = C.fromList diff --git a/examples/Implanted.hs b/examples/Implanted.hs index 34878a0..b1da66d 100644 --- a/examples/Implanted.hs +++ b/examples/Implanted.hs @@ -2,13 +2,14 @@ UnicodeSyntax #-} import qualified Data.Collections as C +import Data.Default import MiseRafturai import Network import Network.HTTP.Lucu import Prelude.Unicode main ∷ IO () -main = let config = defaultConfig { cnfServerPort = "9999" } +main = let config = def { cnfServerPort = "9999" } tree ∷ ResourceTree tree = C.fromList [ ([], nonGreedy miseRafturai) ] in diff --git a/examples/ImplantedSmall.hs b/examples/ImplantedSmall.hs index fe45b89..2f8f066 100644 --- a/examples/ImplantedSmall.hs +++ b/examples/ImplantedSmall.hs @@ -2,13 +2,14 @@ UnicodeSyntax #-} import qualified Data.Collections as C +import Data.Default import Network import Network.HTTP.Lucu import Prelude.Unicode import SmallFile main ∷ IO () -main = let config = defaultConfig { cnfServerPort = "9999" } +main = let config = def { cnfServerPort = "9999" } tree ∷ ResourceTree tree = C.fromList [ ([], nonGreedy smallFile) ] in diff --git a/examples/Multipart.hs b/examples/Multipart.hs index ab857a8..f7122f9 100644 --- a/examples/Multipart.hs +++ b/examples/Multipart.hs @@ -7,6 +7,7 @@ import qualified Data.ByteString.Lazy.Char8 as Lazy import Control.Applicative import qualified Data.Collections as C import Control.Monad.Unicode +import Data.Default import Data.Maybe import Data.Monoid.Unicode import Network @@ -19,7 +20,7 @@ import Text.Blaze.Html5.Attributes hiding (form, title) import Text.Blaze.Renderer.Utf8 main ∷ IO () -main = let config = defaultConfig { cnfServerPort = "9999" } +main = let config = def { cnfServerPort = "9999" } tree ∷ ResourceTree tree = C.fromList [ ([], nonGreedy resMain) ] in @@ -48,7 +49,7 @@ resMain = C.fromList let text = fromMaybe (∅) $ fdContent <$> lookup "text" f file = fromMaybe (∅) $ fdContent <$> lookup "file" f fileName = fdFileName =≪ lookup "file" f - setContentType $ parseMIMEType "text/plain" + setContentType [mimeType| text/plain |] putChunks $ "You entered \"" ⊕ text ⊕ "\".\n" putChunks $ "You uploaded a " ⊕ Lazy.pack (show $ Lazy.length file) ⊕ " bytes long file.\n" putChunks $ "The file name is " ⊕ Lazy.pack (show fileName) ⊕ ".\n" diff --git a/examples/SSL.hs b/examples/SSL.hs index f78b6c2..cbf75dc 100644 --- a/examples/SSL.hs +++ b/examples/SSL.hs @@ -9,6 +9,7 @@ import Control.Monad.IO.Class import Control.Monad.Unicode import qualified Data.ByteString.Lazy.Char8 as Lazy import qualified Data.Collections as C +import Data.Default import Data.Time.Clock import Network import Network.HTTP.Lucu @@ -29,7 +30,7 @@ main = withOpenSSL $ SSL.contextSetCertificate ctx cert SSL.contextSetDefaultCiphers ctx - let config = defaultConfig { + let config = def { cnfServerPort = "9000" , cnfSSLConfig = Just SSLConfig { sslServerPort = "9001"