-- 1xx responses don't have a body.
-- 2xx responses don't need a body to be completed.
-- 3xx:
- | toStatusCode resStatus ≡ Just MovedPermanently
+ | resStatus ≈ MovedPermanently
= txt ("The resource at " ⧺ path ⧺ " has been moved to ")
<+>
eelem "a" += sattr "href" loc
<+>
txt " permanently."
- | toStatusCode resStatus ≡ Just Found
+ | resStatus ≈ Found
= txt ("The resource at " ⧺ path ⧺ " is currently located at ")
<+>
eelem "a" += sattr "href" loc
<+>
txt ". This is not a permanent relocation."
- | toStatusCode resStatus ≡ Just SeeOther
+ | resStatus ≈ SeeOther
= txt ("The resource at " ⧺ path ⧺ " can be found at ")
<+>
eelem "a" += sattr "href" loc
<+>
txt "."
- | toStatusCode resStatus ≡ Just TemporaryRedirect
+ | resStatus ≈ TemporaryRedirect
= txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
<+>
eelem "a" += sattr "href" loc
txt "."
-- 4xx:
- | toStatusCode resStatus ≡ Just BadRequest
+ | resStatus ≈ BadRequest
= txt "The server could not understand the request you sent."
- | toStatusCode resStatus ≡ Just Unauthorized
+ | resStatus ≈ Unauthorized
= txt ("You need a valid authentication to access " ⧺ path)
- | toStatusCode resStatus ≡ Just Forbidden
+ | resStatus ≈ Forbidden
= txt ("You don't have permission to access " ⧺ path)
- | toStatusCode resStatus ≡ Just NotFound
+ | resStatus ≈ NotFound
= txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
- | toStatusCode resStatus ≡ Just Gone
+ | resStatus ≈ Gone
= txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
- | toStatusCode resStatus ≡ Just RequestEntityTooLarge
+ | resStatus ≈ RequestEntityTooLarge
= txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
- | toStatusCode resStatus ≡ Just RequestURITooLarge
+ | resStatus ≈ RequestURITooLarge
= txt "The request URI you sent was too large to accept."
-- 5xx:
- | toStatusCode resStatus ≡ Just InternalServerError
+ | resStatus ≈ InternalServerError
= txt ("An internal server error has occured during the process of your request to " ⧺ path)
- | toStatusCode resStatus ≡ Just ServiceUnavailable
+ | resStatus ≈ ServiceUnavailable
= txt "The service is temporarily unavailable. Try later."
| otherwise
$ A.toAsciiBuilder "Inappropriate status code for a response: "
⊕ printStatusCode resStatus
- when ( toStatusCode resStatus ≡ Just MethodNotAllowed ∧
- hasHeader "Allow" res )
+ when ( resStatus ≈ MethodNotAllowed ∧
+ hasHeader "Allow" res )
$ abort'
$ A.toAsciiBuilder "The status was "
⊕ printStatusCode resStatus
⊕ A.toAsciiBuilder " but no \"Allow\" header."
- when ( toStatusCode resStatus ≢ Just NotModified ∧
- isRedirection resStatus ∧
+ when ( resStatus ≉ NotModified ∧
+ isRedirection resStatus ∧
hasHeader "Location" res )
$ abort'
$ A.toAsciiBuilder "The status code was "
import qualified Data.Text as T
import Data.Time
import qualified Data.Time.HTTP as HTTP
-import Data.Typeable
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Authentication
import Network.HTTP.Lucu.Config
-- 'isRedirection' or it raises an error.
redirect ∷ StatusCode sc ⇒ sc → URI → Resource ()
redirect sc uri
- = do when (cast sc ≡ Just NotModified ∨ (¬) (isRedirection sc))
+ = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
$ abort
$ mkAbortion' InternalServerError
$ A.toText
, printStatusCode
, printResponse
+ , (≈)
+ , (≉)
, isInformational
, isSuccessful
, isRedirection
resCanHaveBody ∷ Response → Bool
{-# INLINEABLE resCanHaveBody #-}
resCanHaveBody (Response {..})
- | isInformational resStatus = False
- | toStatusCode resStatus ≡ Just NoContent = False
- | toStatusCode resStatus ≡ Just ResetContent = False
- | toStatusCode resStatus ≡ Just NotModified = False
- | otherwise = True
+ | isInformational resStatus = False
+ | resStatus ≈ NoContent = False
+ | resStatus ≈ ResetContent = False
+ | resStatus ≈ NotModified = False
+ | otherwise = True
-- |Convert a 'Response' to 'AsciiBuilder'.
printResponse ∷ Response → AsciiBuilder
{-# LANGUAGE
- DeriveDataTypeable
- , QuasiQuotes
+ QuasiQuotes
#-}
-- |Definition of HTTP status code.
-- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named status
, NotExtended(..)
)
where
-import Data.Typeable
import Network.HTTP.Lucu.StatusCode.Internal
[statusCodes|
{-# LANGUAGE
- DeriveDataTypeable
- , ExistentialQuantification
+ ExistentialQuantification
, FlexibleInstances
, TemplateHaskell
, UnicodeSyntax
module Network.HTTP.Lucu.StatusCode.Internal
( StatusCode(..)
, SomeStatusCode(..)
+ , (≈)
+ , (≉)
, statusCodes
)
where
import Data.Attoparsec.Lazy as LP
import qualified Data.ByteString.Lazy.Char8 as Lazy
import Data.List
-import Data.Typeable
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
-- 'statusCodes'
--
-- Minimal complete definition: 'numericCode' and 'textualStatus'.
-class (Eq sc, Show sc, Typeable sc) ⇒ StatusCode sc where
+class Show sc ⇒ StatusCode sc where
-- |Return the 3-digit integer for this status e.g. @200@
numericCode ∷ sc → Int
-- |Return the combination of 3-digit integer and reason phrase
-- |Wrap the status code into 'SomeStatusCode'.
fromStatusCode ∷ sc → SomeStatusCode
fromStatusCode = SomeStatusCode
- -- |Cast the status code from 'SomeStatusCode'.
- toStatusCode ∷ SomeStatusCode → Maybe sc
- toStatusCode (SomeStatusCode sc) = cast sc
-- |Container type for 'StatusCode' type class.
data SomeStatusCode
= ∀sc. StatusCode sc ⇒ SomeStatusCode sc
- deriving Typeable
instance Show SomeStatusCode where
show (SomeStatusCode sc) = show sc
--- |Two 'StatusCode's @a@ and @b@ are said to be equivalent iff
--- @'numericCode' a == 'numericCode' b@.
instance Eq SomeStatusCode where
- (SomeStatusCode α) == (SomeStatusCode β)
- = numericCode α ≡ numericCode β
+ (SomeStatusCode α) == (SomeStatusCode β) = α ≈ β
+
+infix 4 ≈, ≉
+-- |Two 'StatusCode's @a@ and @b@ are said to be equivalent iff
+-- @'numericCode' a '==' 'numericCode' b@.
+--
+-- U+2248, ALMOST EQUAL TO
+(≈) ∷ (StatusCode α, StatusCode β) ⇒ α → β → Bool
+{-# INLINE (≈) #-}
+α ≈ β = numericCode α ≡ numericCode β
+
+-- |@(a ≉ b) '==' 'not' (a ≈ b)@
+--
+-- U+2249, NOT ALMOST EQUAL TO
+(≉) ∷ (StatusCode α, StatusCode β) ⇒ α → β → Bool
+{-# INLINE (≉) #-}
+(≉) = ((¬) ∘) ∘ (≈)
instance StatusCode SomeStatusCode where
numericCode (SomeStatusCode sc) = numericCode sc
textualStatus (SomeStatusCode sc) = textualStatus sc
fromStatusCode = id
- toStatusCode = Just
-- |'QuasiQuoter' for 'StatusCode' declarations.
--
-- becomes:
--
-- @
--- data OK = OK deriving ('Eq', 'Show', 'Typeable')
+-- data OK = OK deriving ('Show')
-- instance OK where
-- 'numericCode' _ = 200
-- 'textualStatus' _ = 'A.unsafeFromString' \"200 OK\"
--
--- data BadRequest = BadRequest deriving ('Eq', 'Show', 'Typeable')
+-- data BadRequest = BadRequest deriving ('Show')
-- instance BadRequest where
-- 'numericCode' _ = 400
-- 'textualStatus' _ = 'A.unsafeFromString' \"400 Bad Request\"
--
--- data MethodNotAllowed = MethodNotAllowed deriving ('Eq', 'Show', 'Typeable')
+-- data MethodNotAllowed = MethodNotAllowed deriving ('Show')
-- instance MethodNotAllowed where
-- 'numericCode' _ = 405
-- 'textualStatus' _ = 'A.unsafeFromString' \"405 Method Not Allowed\"
name = mkName $ concatMap A.toString phrase
dataDecl ∷ Q Dec
- dataDecl = dataD (cxt [])
- name
- []
- [con]
- [ mkName "Eq"
- , mkName "Show"
- , mkName "Typeable"
- ]
+ dataDecl = dataD (cxt []) name [] [con] [''Show]
instanceDecl ∷ Q [Dec]
instanceDecl
- PHO <pho@cielonegro.org>
- closed with disposition fixed
- Done.
+- - 2011-11-07 02:03:42.159681 Z
+ - PHO <pho@cielonegro.org>
+ - changed status from closed to in_progress
+ - Each instances of StatusCode should not be an instance of Eq.
+- - 2011-11-07 15:23:25.827332 Z
+ - PHO <pho@cielonegro.org>
+ - closed with disposition fixed
+ - Done.
git_branch: template-haskell
projects / Lucu.git / commitdiff