Code clean-up using convertible-text.

Ditz-issue: 0a2a377be55430e655ab42fdc4902fa56a058b26

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index e106774fafe6777faf7a066d7188f77df1e4a974..d95291764cf2ecd7c1b4c0e8beebe84a1f20744c 100644 (file)
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE
     OverloadedStrings
   , RecordWildCards
 {-# LANGUAGE
     OverloadedStrings
   , RecordWildCards

+  , ScopedTypeVariables

   , TypeOperators
   , UnicodeSyntax
   #-}
   , TypeOperators
   , UnicodeSyntax
   #-}


@@ -14,6 +15,7 @@ import Blaze.ByteString.Builder (Builder)
 import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
 import qualified Data.CaseInsensitive as CI
 import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
 import qualified Data.CaseInsensitive as CI

+import Data.Convertible.Utils

 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Text (Text)
 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Text (Text)


@@ -38,14 +40,14 @@ defaultPageForResponse ∷ Config → Maybe Request → Response → Builder
 defaultPageForResponse conf req res
     = defaultPageWithMessage conf (resStatus res) $ defaultMessage req res
 
 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 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
          docType
          html ! xmlns "http://www.w3.org/1999/xhtml" $
 {-# INLINEABLE defaultPageWithMessage #-}
 defaultPageWithMessage (Config {..}) sc msg
     = renderHtmlBuilder $
       do unsafeByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
          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
                 head $ title status
                 body $ do h1 status
                           p msg


@@ -53,6 +55,9 @@ defaultPageWithMessage (Config {..}) sc msg
                           address $ do toHtml $ A.toText cnfServerSoftware
                                        unsafeByteString " at "
                                        toHtml $ CI.original cnfServerHost
                           address $ do toHtml $ A.toText cnfServerSoftware
                                        unsafeByteString " at "
                                        toHtml $ CI.original cnfServerHost

+    where
+      scText ∷ sc → Text
+      scText = convertSuccessVia ((⊥) ∷ Ascii) ∘ fromStatusCode

 
 defaultMessage ∷ Maybe Request → Response → Html
 {-# INLINEABLE defaultMessage #-}
 
 defaultMessage ∷ Maybe Request → Response → Html
 {-# INLINEABLE defaultMessage #-}

diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
index d77c976004beefbeb0d6bc55c45bb419185af3ca..6a791e4d15792a5aaff5a4504ceb6e10930e7a22 100644 (file)
--- a/Network/HTTP/Lucu/MIMEType/Guess.hs
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -17,8 +17,8 @@ module Network.HTTP.Lucu.MIMEType.Guess
     )
     where
 import Control.Applicative
     )
     where
 import Control.Applicative

-import Data.Attoparsec.Char8 as P
-import Data.Attoparsec.Lazy as LP
+import Data.Attoparsec.Char8
+import qualified Data.Attoparsec.Lazy as LP

 import qualified Data.ByteString.Lazy.Char8 as Lazy
 import qualified Data.Map as M
 import Data.Map (Map)
 import qualified Data.ByteString.Lazy.Char8 as Lazy
 import qualified Data.Map as M
 import Data.Map (Map)


@@ -103,7 +103,7 @@ parseExtMap src
              "pair"
 
       ext ∷ Parser Text
              "pair"
 
       ext ∷ Parser Text

-      ext = (decodeUtf8 <$> P.takeWhile1 isAlphaNum)
+      ext = (decodeUtf8 <$> takeWhile1 isAlphaNum)

             <?>
             "ext"
 
             <?>
             "ext"
 

diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index 30a4adb7dd3f11885254d8762862ad344a1daede..882ff76668dc60bcb721eaefd83f1d4555d5303a 100644 (file)
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -1,10 +1,13 @@
 {-# LANGUAGE
     DoAndIfThenElse
 {-# LANGUAGE
     DoAndIfThenElse

+  , FlexibleInstances

   , FlexibleContexts
   , FlexibleContexts

+  , MultiParamTypeClasses

   , OverloadedStrings
   , QuasiQuotes
   , RecordWildCards
   , ScopedTypeVariables
   , OverloadedStrings
   , QuasiQuotes
   , RecordWildCards
   , ScopedTypeVariables

+  , TemplateHaskell

   , UnicodeSyntax
   , ViewPatterns
   #-}
   , UnicodeSyntax
   , ViewPatterns
   #-}


@@ -19,7 +22,7 @@ import Control.Applicative hiding (many)
 import Control.Applicative.Unicode hiding ((∅))
 import Control.Monad.Error (MonadError, throwError)
 import Control.Monad.Unicode
 import Control.Applicative.Unicode hiding ((∅))
 import Control.Monad.Error (MonadError, throwError)
 import Control.Monad.Unicode

-import Data.Ascii (Ascii, CIAscii)
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)

 import qualified Data.Ascii as A
 import Data.Attoparsec
 import qualified Data.Attoparsec.Lazy as LP
 import qualified Data.Ascii as A
 import Data.Attoparsec
 import qualified Data.Attoparsec.Lazy as LP


@@ -72,13 +75,18 @@ data ContDispo
       , dParams ∷ !MIMEParams
       }
 
       , dParams ∷ !MIMEParams
       }
 

--- FIXME
-printContDispo ∷ ContDispo → Ascii
-printContDispo d
-    = A.fromAsciiBuilder
-      ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
-        ⊕
-        cs (dParams d) )
+instance ConvertSuccess ContDispo Ascii where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess ContDispo AsciiBuilder where
+    {-# INLINE convertSuccess #-}
+    convertSuccess (ContDispo {..})
+        = cs dType ⊕ cs dParams
+
+deriveAttempts [ ([t| ContDispo |], [t| Ascii        |])
+               , ([t| ContDispo |], [t| AsciiBuilder |])
+               ]

 
 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
 -- @'Right' result@. Note that there are currently the following
 
 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
 -- @'Right' result@. Note that there are currently the following


@@ -241,7 +249,7 @@ partName (Part {..})
                                       ⧺ T.unpack name
         Nothing
             → throwError $ "form-data without name: "
                                       ⧺ T.unpack name
         Nothing
             → throwError $ "form-data without name: "

-                         ⧺ A.toString (printContDispo ptContDispo)
+                         â\8a\95 convertSuccessVia ((â\8a¥) â\88· Ascii) ptContDispo

 
 partFileName ∷ Part → Maybe Text
 partFileName (ptContDispo → ContDispo {..})
 
 partFileName ∷ Part → Maybe Text
 partFileName (ptContDispo → ContDispo {..})

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index a8359758f9d90eaf107f58fc2bb4cf008b611cac..4ba7865d466f499a11d6a5f86c133bfc34b705f4 100644 (file)
--- 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 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)
 import Data.Maybe
 import Data.Monoid.Unicode
 import GHC.Conc (unsafeIOToSTM)


@@ -44,29 +44,28 @@ abortOnCertainConditions (NI {..})
                                                , isError
                                                ])
                    $ abort'
                                                , 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'
 
                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'
 
                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
 
       abort' ∷ AsciiBuilder → STM ()
       abort' = throwSTM
                ∘ mkAbortion' InternalServerError

-               ∘ A.toText
-               ∘ A.fromAsciiBuilder
+               ∘ cs

 
 postprocessWithRequest ∷ NormalInteraction → STM ()
 postprocessWithRequest ni@(NI {..})
 
 postprocessWithRequest ∷ NormalInteraction → STM ()
 postprocessWithRequest ni@(NI {..})

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index b478503c8bc53d6af8b74e6b9cf196350b1772c2..a970b46f9f695595f435793768c2285b51221490 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -156,6 +156,8 @@ import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import Data.Collections
 import Data.Convertible.Base
 import 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.List (intersperse, sort)
 import Data.Maybe
 import Data.Monoid


@@ -234,8 +236,7 @@ getQueryForm = parse' <$> getRequestURI
     where
       parse' = map toPairWithFormData ∘
                parseWWWFormURLEncoded ∘
     where
       parse' = map toPairWithFormData ∘
                parseWWWFormURLEncoded ∘

-               fromJust ∘
-               A.fromChars ∘
+               convertUnsafe ∘

                drop 1 ∘
                uriQuery
 
                drop 1 ∘
                uriQuery
 


@@ -265,10 +266,10 @@ getAccept
            Nothing
                → return []
            Just accept
            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
                     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
 
 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
 -- value of request header \"Accept-Encoding\". The list is sorted in


@@ -293,10 +294,10 @@ getAcceptEncoding
                       -- identity のみが許される。
                       return [("identity", Nothing)]
                  else
                       -- 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
                        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)
     where
       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)


@@ -317,10 +318,10 @@ getContentType
            Nothing
                → return Nothing
            Just cType
            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
                     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'.
 
 -- |Return the value of request header \"Authorization\" as
 -- 'AuthCredential'.


@@ -331,7 +332,7 @@ getAuthorization
            Nothing
                → return Nothing
            Just auth
            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
 
                     Right ac → return $ Just ac
                     Left  _  → return Nothing
 


@@ -379,7 +380,6 @@ foundETag tag
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "ETag"
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "ETag"

-             $ A.fromAsciiBuilder

              $ cs tag
          when (method ≡ POST)
              $ abort
              $ cs tag
          when (method ≡ POST)
              $ abort


@@ -395,17 +395,17 @@ foundETag tag
                → if value ≡ "*" then
                       return ()
                   else
                → 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
                         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
                         Left _
                             → abort $ mkAbortion' BadRequest

-                                    $ "Unparsable If-Match: " ⊕ A.toText value
+                                    $ "Unparsable If-Match: " ⊕ cs value

 
          let statusForNoneMatch
                  = if method ≡ GET ∨ method ≡ HEAD then
 
          let statusForNoneMatch
                  = if method ≡ GET ∨ method ≡ HEAD then


@@ -423,15 +423,15 @@ foundETag tag
                       abort $ mkAbortion' statusForNoneMatch
                             $ "The entity tag matches: *"
                   else
                       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
                         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
                         Left _
                             → abort $ mkAbortion' BadRequest

-                                    $ "Unparsable If-None-Match: " ⊕ A.toText value
+                                    $ "Unparsable If-None-Match: " ⊕ cs value

 
          driftTo ReceivingBody
 
 
          driftTo ReceivingBody
 


@@ -472,10 +472,10 @@ foundTimeStamp timeStamp
                              → when (timeStamp ≤ lastTime)
                                $ abort
                                $ mkAbortion' statusForIfModSince
                              → when (timeStamp ≤ lastTime)
                                $ abort
                                $ mkAbortion' statusForIfModSince

-                               $ "The entity has not been modified since " ⊕ A.toText str
+                               $ "The entity has not been modified since " ⊕ cs str

                          Nothing
                              → abort $ mkAbortion' BadRequest
                          Nothing
                              → abort $ mkAbortion' BadRequest

-                                     $ "Malformed If-Modified-Since: " ⊕ A.toText str
+                                     $ "Malformed If-Modified-Since: " ⊕ cs str

            Nothing  → return ()
 
          ifUnmodSince ← getHeader "If-Unmodified-Since"
            Nothing  → return ()
 
          ifUnmodSince ← getHeader "If-Unmodified-Since"


@@ -485,10 +485,10 @@ foundTimeStamp timeStamp
                              → when (timeStamp > lastTime)
                                $ abort
                                $ mkAbortion' PreconditionFailed
                              → when (timeStamp > lastTime)
                                $ abort
                                $ mkAbortion' PreconditionFailed

-                               $ "The entity has not been modified since " ⊕ A.toText str
+                               $ "The entity has not been modified since " ⊕ cs str

                          Nothing
                              → abort $ mkAbortion' BadRequest
                          Nothing
                              → abort $ mkAbortion' BadRequest

-                                     $ "Malformed If-Unmodified-Since: " ⊕ A.toText str
+                                     $ "Malformed If-Unmodified-Since: " ⊕ cs str

            Nothing  → return ()
 
          driftTo ReceivingBody
            Nothing  → return ()
 
          driftTo ReceivingBody


@@ -597,9 +597,9 @@ getForm limit
             (bsToAscii =≪ getChunks limit)
 
       bsToAscii bs
             (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
 
       readMultipartFormData m
           = case lookup "boundary" m of


@@ -607,12 +607,12 @@ getForm limit
                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
               Just boundary
                   → do src ← getChunks limit
                   → 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
                        case parseMultipartFormData b src of

-                         Right xs → return $ map (first A.toByteString) xs
+                         Right xs → return $ map (first cs) xs

                          Left err → abort $ mkAbortion' BadRequest $ T.pack err
 
 -- |@'redirect' code uri@ declares the response status as @code@ and
                          Left err → abort $ mkAbortion' BadRequest $ T.pack err
 
 -- |@'redirect' code uri@ declares the response status as @code@ and


@@ -623,10 +623,9 @@ redirect sc uri
     = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
              $ abort
              $ mkAbortion' InternalServerError
     = 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
 
          setStatus sc
          setLocation uri
 

diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs
index e9da057c4bdb07415ccc944bd6bcd902f81354d1..8f45440a603411875b05a8d35a760734660941f9 100644 (file)
--- a/Network/HTTP/Lucu/Response.hs
+++ b/Network/HTTP/Lucu/Response.hs
@@ -1,6 +1,9 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    OverloadedStrings
+    FlexibleInstances
+  , MultiParamTypeClasses
+  , OverloadedStrings

   , RecordWildCards
   , RecordWildCards

+  , TemplateHaskell

   , UnicodeSyntax
   , ViewPatterns
   #-}
   , UnicodeSyntax
   , ViewPatterns
   #-}


@@ -17,8 +20,6 @@ module Network.HTTP.Lucu.Response
     , emptyResponse
     , setStatusCode
     , resCanHaveBody
     , emptyResponse
     , setStatusCode
     , resCanHaveBody

-    , printStatusCode
-    , printResponse

 
     , (≈)
     , (≉)
 
     , (≈)
     , (≉)


@@ -30,8 +31,7 @@ module Network.HTTP.Lucu.Response
     , isServerError
     )
     where
     , 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.Convertible.Base
 import Data.Convertible.Instances.Ascii ()
 import Data.Convertible.Utils


@@ -42,11 +42,6 @@ import Network.HTTP.Lucu.StatusCode
 import Network.HTTP.Lucu.StatusCode.Internal
 import Prelude.Unicode
 
 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
 -- |This is the definition of an HTTP response.
 data Response = Response {
       resVersion ∷ !HttpVersion


@@ -58,6 +53,23 @@ instance HasHeaders Response where
     getHeaders         = resHeaders
     setHeaders res hdr = res { resHeaders = hdr }
 
     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
 -- |Returns an HTTP\/1.1 'Response' with no header fields.
 emptyResponse ∷ StatusCode sc ⇒ sc → Response
 emptyResponse sc


@@ -85,16 +97,6 @@ resCanHaveBody (Response {..})
     | resStatus ≈ NotModified   = False
     | otherwise                 = True
 
     | resStatus ≈ NotModified   = False
     | otherwise                 = True
 

--- |Convert a 'Response' to 'AsciiBuilder'.
-printResponse ∷ Response → AsciiBuilder
-{-# INLINEABLE printResponse #-}
-printResponse (Response {..})
-    = cs resVersion ⊕
-      A.toAsciiBuilder " "        ⊕
-      printStatusCode  resStatus  ⊕
-      A.toAsciiBuilder "\x0D\x0A" ⊕
-      cs resHeaders
-

 -- |@'isInformational' sc@ returns 'True' iff @sc '<' 200@.
 isInformational ∷ StatusCode sc ⇒ sc → Bool
 {-# INLINE isInformational #-}
 -- |@'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 b4809eaa52e4d975b4afc16b8300a396ed85fe70..15f3d6884064715c1281f9f0c42fe12bdca6bc78 100644 (file)
--- 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 Control.Concurrent.STM
 import Control.Exception
 import Control.Monad

+import Data.Ascii (AsciiBuilder)
+import Data.Convertible.Utils

 import GHC.IO.Exception (IOException(..), IOErrorType(..))
 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(..))
 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 = (∅)
                              }
                              , resStatus  = fromStatusCode Continue
                              , resHeaders = (∅)
                              }

-                  hPutBuilder cHandle $ A.toBuilder $ printResponse cont
+                  hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) cont

                   hFlush cHandle
          writeHeader ctx ni
 
                   hFlush cHandle
          writeHeader ctx ni
 


@@ -117,7 +118,7 @@ writeHeader ctx@(Context {..}) ni@(NI {..})
                       readTVar niResponse
                   else
                       retry -- Too early to write header fields.
                       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
 
          hFlush cHandle
          writeBodyIfNeeded ctx ni
 


@@ -231,7 +232,7 @@ writeResponseForSEI ∷ HandleLike h
                     → SemanticallyInvalidInteraction
                     → IO ()
 writeResponseForSEI ctx@(Context {..}) (SEI {..})
                     → 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
          unless seiWillDiscardBody $
              if seiWillChunkBody then
                  do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend


@@ -249,7 +250,7 @@ writeResponseForSYI ∷ HandleLike h
                     → SyntacticallyInvalidInteraction
                     → IO ()
 writeResponseForSYI (Context {..}) (SYI {..})
                     → SyntacticallyInvalidInteraction
                     → IO ()
 writeResponseForSYI (Context {..}) (SYI {..})

-    = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
+    = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) syiResponse

          hPutBuilder cHandle syiBodyToSend
          hFlush cHandle
          return ()
          hPutBuilder cHandle syiBodyToSend
          hFlush cHandle
          return ()

diff --git a/Network/HTTP/Lucu/StatusCode/Internal.hs b/Network/HTTP/Lucu/StatusCode/Internal.hs
index d6e892b52259156bb7bcdf591b2983a9e7023a53..1d9117ceb1d3ade43416efe25ea0261a76fecb24 100644 (file)
--- a/Network/HTTP/Lucu/StatusCode/Internal.hs
+++ b/Network/HTTP/Lucu/StatusCode/Internal.hs
@@ -1,10 +1,13 @@
 {-# LANGUAGE
     ExistentialQuantification
   , FlexibleInstances
 {-# LANGUAGE
     ExistentialQuantification
   , FlexibleInstances

+  , MultiParamTypeClasses
+  , OverlappingInstances

   , TemplateHaskell
   , UnicodeSyntax
   , ViewPatterns
   #-}
   , TemplateHaskell
   , UnicodeSyntax
   , ViewPatterns
   #-}

+{-# OPTIONS_GHC -fno-warn-orphans #-}

 module Network.HTTP.Lucu.StatusCode.Internal
     ( StatusCode(..)
     , SomeStatusCode(..)
 module Network.HTTP.Lucu.StatusCode.Internal
     ( StatusCode(..)
     , SomeStatusCode(..)


@@ -14,11 +17,14 @@ module Network.HTTP.Lucu.StatusCode.Internal
     )
     where
 import Control.Applicative
     )
     where
 import Control.Applicative

-import Data.Ascii (Ascii)
+import Data.Ascii (Ascii, AsciiBuilder)

 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8 as P
 import Data.Attoparsec.Lazy as LP
 import qualified Data.ByteString.Lazy.Char8 as Lazy
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8 as P
 import Data.Attoparsec.Lazy as LP
 import qualified Data.ByteString.Lazy.Char8 as Lazy

+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils

 import Data.List
 import Language.Haskell.TH.Lib
 import Language.Haskell.TH.Syntax
 import Data.List
 import Language.Haskell.TH.Lib
 import Language.Haskell.TH.Syntax


@@ -73,6 +79,22 @@ instance StatusCode SomeStatusCode where
     textualStatus (SomeStatusCode sc) = textualStatus sc
     fromStatusCode = id
 
     textualStatus (SomeStatusCode sc) = textualStatus sc
     fromStatusCode = id
 

+instance StatusCode sc ⇒ ConvertSuccess sc Ascii where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance StatusCode sc ⇒ ConvertSuccess sc AsciiBuilder where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = cs ∘ textualStatus
+
+instance StatusCode sc ⇒ ConvertAttempt sc Ascii where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = return ∘ cs
+
+instance StatusCode sc ⇒ ConvertAttempt sc AsciiBuilder where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = return ∘ cs
+

 -- |'QuasiQuoter' for 'StatusCode' declarations.
 --
 -- Top-level splicing
 -- |'QuasiQuoter' for 'StatusCode' declarations.
 --
 -- Top-level splicing