From 3318fe04b2d541a29228a96f69e0dcf81392a38f Mon Sep 17 00:00:00 2001 From: PHO Date: Tue, 8 Nov 2011 00:23:30 +0900 Subject: [PATCH] Each instances of StatusCode should not be an instance of Eq. Ditz-issue: c566a8433e8af700655680f53e99cfe9f563ed32 --- Network/HTTP/Lucu/DefaultPage.hs | 26 +++++----- Network/HTTP/Lucu/Postprocess.hs | 8 +-- Network/HTTP/Lucu/Resource.hs | 3 +- Network/HTTP/Lucu/Response.hs | 12 +++-- Network/HTTP/Lucu/StatusCode.hs | 4 +- Network/HTTP/Lucu/StatusCode/Internal.hs | 49 ++++++++++--------- ...6a8433e8af700655680f53e99cfe9f563ed32.yaml | 8 +++ 7 files changed, 59 insertions(+), 51 deletions(-) diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 8fcc37d..1ae5abd 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -79,7 +79,7 @@ getMsg req res@(Response {..}) -- 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 @@ -87,7 +87,7 @@ getMsg req res@(Response {..}) <+> txt " permanently." - | toStatusCode resStatus ≡ Just Found + | resStatus ≈ Found = txt ("The resource at " ⧺ path ⧺ " is currently located at ") <+> eelem "a" += sattr "href" loc @@ -95,7 +95,7 @@ getMsg req res@(Response {..}) <+> 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 @@ -103,7 +103,7 @@ getMsg req res@(Response {..}) <+> txt "." - | toStatusCode resStatus ≡ Just TemporaryRedirect + | resStatus ≈ TemporaryRedirect = txt ("The resource at " ⧺ path ⧺ " is temporarily located at ") <+> eelem "a" += sattr "href" loc @@ -112,25 +112,25 @@ getMsg req res@(Response {..}) 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 diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 29c3c51..09665c6 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -47,15 +47,15 @@ abortOnCertainConditions (NI {..}) $ 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 " diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index f7b90f9..97b2cbe 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -161,7 +161,6 @@ import Data.Text (Text) 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 @@ -615,7 +614,7 @@ getForm limit -- '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 diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index 0ebfa71..191cebd 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -19,6 +19,8 @@ module Network.HTTP.Lucu.Response , printStatusCode , printResponse + , (≈) + , (≉) , isInformational , isSuccessful , isRedirection @@ -66,11 +68,11 @@ emptyResponse sc 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 diff --git a/Network/HTTP/Lucu/StatusCode.hs b/Network/HTTP/Lucu/StatusCode.hs index 950d964..2dd3863 100644 --- a/Network/HTTP/Lucu/StatusCode.hs +++ b/Network/HTTP/Lucu/StatusCode.hs @@ -1,6 +1,5 @@ {-# LANGUAGE - DeriveDataTypeable - , QuasiQuotes + QuasiQuotes #-} -- |Definition of HTTP status code. -- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named status @@ -70,7 +69,6 @@ module Network.HTTP.Lucu.StatusCode , NotExtended(..) ) where -import Data.Typeable import Network.HTTP.Lucu.StatusCode.Internal [statusCodes| diff --git a/Network/HTTP/Lucu/StatusCode/Internal.hs b/Network/HTTP/Lucu/StatusCode/Internal.hs index 3addcf2..24988ee 100644 --- a/Network/HTTP/Lucu/StatusCode/Internal.hs +++ b/Network/HTTP/Lucu/StatusCode/Internal.hs @@ -1,6 +1,5 @@ {-# LANGUAGE - DeriveDataTypeable - , ExistentialQuantification + ExistentialQuantification , FlexibleInstances , TemplateHaskell , UnicodeSyntax @@ -9,6 +8,8 @@ module Network.HTTP.Lucu.StatusCode.Internal ( StatusCode(..) , SomeStatusCode(..) + , (≈) + , (≉) , statusCodes ) where @@ -19,7 +20,6 @@ import Data.Attoparsec.Char8 as P 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 @@ -32,7 +32,7 @@ import Prelude.Unicode -- '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 @@ -41,29 +41,37 @@ class (Eq sc, Show sc, Typeable sc) ⇒ StatusCode sc where -- |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. -- @@ -80,17 +88,17 @@ instance StatusCode SomeStatusCode where -- 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\" @@ -148,14 +156,7 @@ statusDecl (num, phrase) 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 diff --git a/bugs/issue-c566a8433e8af700655680f53e99cfe9f563ed32.yaml b/bugs/issue-c566a8433e8af700655680f53e99cfe9f563ed32.yaml index a6fce9c..3f8ad94 100644 --- a/bugs/issue-c566a8433e8af700655680f53e99cfe9f563ed32.yaml +++ b/bugs/issue-c566a8433e8af700655680f53e99cfe9f563ed32.yaml @@ -24,4 +24,12 @@ log_events: - PHO - closed with disposition fixed - Done. +- - 2011-11-07 02:03:42.159681 Z + - PHO + - 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 + - closed with disposition fixed + - Done. git_branch: template-haskell -- 2.40.0