{-# LANGUAGE
OverloadedStrings
, RecordWildCards
+ , ScopedTypeVariables
, TypeOperators
, UnicodeSyntax
#-}
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)
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" $
- 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
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 #-}
)
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)
"pair"
ext ∷ Parser Text
- ext = (decodeUtf8 <$> P.takeWhile1 isAlphaNum)
+ ext = (decodeUtf8 <$> takeWhile1 isAlphaNum)
<?>
"ext"
{-# LANGUAGE
DoAndIfThenElse
+ , FlexibleInstances
, FlexibleContexts
+ , MultiParamTypeClasses
, OverloadedStrings
, QuasiQuotes
, RecordWildCards
, ScopedTypeVariables
+ , TemplateHaskell
, UnicodeSyntax
, ViewPatterns
#-}
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
, 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
⧺ 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 {..})
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)
, 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 {..})
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
where
parse' = map toPairWithFormData ∘
parseWWWFormURLEncoded ∘
- fromJust ∘
- A.fromChars ∘
+ convertUnsafe ∘
drop 1 ∘
uriQuery
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
-- 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)
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'.
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
method ← getMethod
when (method ≡ GET ∨ method ≡ HEAD)
$ setHeader "ETag"
- $ A.fromAsciiBuilder
$ cs tag
when (method ≡ POST)
$ abort
→ 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
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
→ 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
- $ "Malformed If-Modified-Since: " ⊕ A.toText str
+ $ "Malformed If-Modified-Since: " ⊕ cs str
Nothing → return ()
ifUnmodSince ← getHeader "If-Unmodified-Since"
→ 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
- $ "Malformed If-Unmodified-Since: " ⊕ A.toText str
+ $ "Malformed If-Unmodified-Since: " ⊕ cs str
Nothing → return ()
driftTo ReceivingBody
(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
→ 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
+ 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
= 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
{-# LANGUAGE
- OverloadedStrings
+ FlexibleInstances
+ , MultiParamTypeClasses
+ , OverloadedStrings
, RecordWildCards
+ , TemplateHaskell
, UnicodeSyntax
, ViewPatterns
#-}
, emptyResponse
, setStatusCode
, resCanHaveBody
- , printStatusCode
- , printResponse
, (≈)
, (≉)
, 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 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
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
| 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 #-}
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(..))
, resStatus = fromStatusCode Continue
, resHeaders = (∅)
}
- hPutBuilder cHandle $ A.toBuilder $ printResponse cont
+ hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) cont
hFlush cHandle
writeHeader ctx 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
→ 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
→ SyntacticallyInvalidInteraction
→ IO ()
writeResponseForSYI (Context {..}) (SYI {..})
- = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
+ = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) syiResponse
hPutBuilder cHandle syiBodyToSend
hFlush cHandle
return ()
{-# LANGUAGE
ExistentialQuantification
, FlexibleInstances
+ , MultiParamTypeClasses
+ , OverlappingInstances
, TemplateHaskell
, UnicodeSyntax
, ViewPatterns
#-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Network.HTTP.Lucu.StatusCode.Internal
( StatusCode(..)
, SomeStatusCode(..)
)
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 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
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
projects / Lucu.git / commitdiff