--- /dev/null
+{-# LANGUAGE
+ FlexibleContexts
+ , TypeFamilies
+ , UnicodeSyntax
+ #-}
+-- |FIXME: doc
+module Data.Eq.Indirect
+ ( Eq'(..)
+ , (==:)
+ , (/=:)
+ , (≡:)
+ , (≢:)
+ , (≠:)
+ )
+ where
+import Prelude.Unicode
+
+infix 4 ==:{-, /=:, ≡:, ≢:, ≠:-}
+
+-- |FIXME: doc
+class Eq (Unified α) ⇒ Eq' α where
+ -- |FIXME: doc
+ type Unified α
+ -- |FIXME: doc
+ unify ∷ α → Unified α
+
+-- |FIXME: doc
+(==:) ∷ (Eq' α, Eq' β, Unified α ~ Unified β) ⇒ α → β → Bool
+{-# INLINE (==:) #-}
+(==:) = (∘ unify) ∘ (≡) ∘ unify
+
+-- |FIXME: doc
+(/=:) ∷ (Eq' α, Eq' β, Unified α ~ Unified β) ⇒ α → β → Bool
+{-# INLINE (/=:) #-}
+(/=:) = ((¬) ∘) ∘ (==:)
+
+-- |FIXME: doc
+(≡:) ∷ (Eq' α, Eq' β, Unified α ~ Unified β) ⇒ α → β → Bool
+{-# INLINE CONLIKE (≡:) #-}
+(≡:) = (==:)
+
+-- |FIXME: doc
+(≢:) ∷ (Eq' α, Eq' β, Unified α ~ Unified β) ⇒ α → β → Bool
+{-# INLINE CONLIKE (≢:) #-}
+(≢:) = (/=:)
+
+-- |FIXME: doc
+(≠:) ∷ (Eq' α, Eq' β, Unified α ~ Unified β) ⇒ α → β → Bool
+{-# INLINE CONLIKE (≠:) #-}
+(≠:) = (/=:)
-DHAVE_SSL
Exposed-Modules:
+ Data.Eq.Indirect
Data.Collections.Newtype.TH
Network.HTTP.Lucu
Network.HTTP.Lucu.Abortion
import qualified Data.CaseInsensitive as CI
import Data.Convertible.Base
import Data.Convertible.Utils
+import Data.Eq.Indirect
import Data.Maybe
import Data.Monoid.Unicode
import Data.Text (Text)
-- 1xx responses don't have a body.
-- 2xx responses don't need a body to be completed.
-- 3xx:
- | resStatus â\89\88 MovedPermanently
+ | resStatus â\89¡: MovedPermanently
= do unsafeByteString "The resource at "
path
unsafeByteString " has been moved to "
a ! href (toValue loc) $ toHtml loc
unsafeByteString " permanently."
- | resStatus â\89\88 Found
+ | resStatus â\89¡: Found
= do unsafeByteString "The resource at "
path
unsafeByteString " is currently located at "
a ! href (toValue loc) $ toHtml loc
unsafeByteString ". This is not a permanent relocation."
- | resStatus â\89\88 SeeOther
+ | resStatus â\89¡: SeeOther
= do unsafeByteString "The resource at "
path
unsafeByteString " can be found at "
a ! href (toValue loc) $ toHtml loc
unsafeByteString "."
- | resStatus â\89\88 TemporaryRedirect
+ | resStatus â\89¡: TemporaryRedirect
= do unsafeByteString "The resource at "
path
unsafeByteString " is temporarily located at "
unsafeByteString "."
-- 4xx:
- | resStatus â\89\88 BadRequest
+ | resStatus â\89¡: BadRequest
= unsafeByteString "The server could not understand the request you sent."
- | resStatus â\89\88 Unauthorized
+ | resStatus â\89¡: Unauthorized
= unsafeByteString "You need a valid authentication to access " ⊕ path
- | resStatus â\89\88 Forbidden
+ | resStatus â\89¡: Forbidden
= unsafeByteString "You don't have permission to access " ⊕ path
- | resStatus â\89\88 NotFound
+ | resStatus â\89¡: NotFound
= do unsafeByteString "The requested URL "
path
unsafeByteString " was not found on this server."
- | resStatus â\89\88 Gone
+ | resStatus â\89¡: Gone
= do unsafeByteString "The resource at "
path
unsafeByteString " was here in past times, but has gone permanently."
- | resStatus â\89\88 RequestEntityTooLarge
+ | resStatus â\89¡: RequestEntityTooLarge
= do unsafeByteString "The request entity you sent for "
path
unsafeByteString " was too large to accept."
- | resStatus â\89\88 RequestURITooLarge
+ | resStatus â\89¡: RequestURITooLarge
= unsafeByteString "The request URI you sent was too large to accept."
-- 5xx:
- | resStatus â\89\88 InternalServerError
+ | resStatus â\89¡: InternalServerError
= unsafeByteString "An internal server error has occured during the process of your request to " ⊕ path
- | resStatus â\89\88 ServiceUnavailable
+ | resStatus â\89¡: ServiceUnavailable
= unsafeByteString "The service is temporarily unavailable. Try later."
| otherwise
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
import Data.Convertible.Base
+import Data.Eq.Indirect
import Data.Maybe
import Data.Monoid.Unicode
import GHC.Conc (unsafeIOToSTM)
$ cs ("Inappropriate status code for a response: " ∷ Ascii)
⊕ cs resStatus
- when ( resStatus â\89\88 MethodNotAllowed ∧
- hasHeader "Allow" res )
+ when ( resStatus â\89¡: MethodNotAllowed ∧
+ (¬) (hasHeader "Allow" res) )
$ abort'
$ cs ("The status was " ∷ Ascii)
⊕ cs resStatus
⊕ cs (" but no \"Allow\" header." ∷ Ascii)
- when ( resStatus â\89\89 NotModified ∧
- isRedirection resStatus ∧
- hasHeader "Location" res )
+ when ( resStatus â\89¢: NotModified ∧
+ isRedirection resStatus ∧
+ (¬) (hasHeader "Location" res) )
$ abort'
$ cs ("The status code was " ∷ Ascii)
⊕ cs resStatus
import Data.Convertible.Instances.Text ()
import Data.Convertible.Utils
import Data.Default
+import Data.Eq.Indirect
import Data.List (intersperse, sort)
import Data.Maybe
import Data.Monoid
-- 'isRedirection' or it raises an error.
redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc ()
redirect sc uri
- = do when (sc â\89\88 NotModified ∨ (¬) (isRedirection sc))
+ = do when (sc â\89¡: NotModified ∨ (¬) (isRedirection sc))
$ abort
$ mkAbortion' InternalServerError
$ cs
, setStatusCode
, resCanHaveBody
- , (≈)
- , (≉)
, isInformational
, isSuccessful
, isRedirection
import Data.Convertible.Base
import Data.Convertible.Instances.Ascii ()
import Data.Convertible.Utils
+import Data.Eq.Indirect
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
{-# INLINEABLE resCanHaveBody #-}
resCanHaveBody (Response {..})
| isInformational resStatus = False
- | resStatus â\89\88 NoContent = False
- | resStatus â\89\88 ResetContent = False
- | resStatus â\89\88 NotModified = False
+ | resStatus â\89¡: NoContent = False
+ | resStatus â\89¡: ResetContent = False
+ | resStatus â\89¡: NotModified = False
| otherwise = True
-- |@'isInformational' sc@ returns 'True' iff @sc '<' 200@.
, MultiParamTypeClasses
, OverlappingInstances
, TemplateHaskell
+ , TypeFamilies
, UndecidableInstances
, UnicodeSyntax
, ViewPatterns
module Network.HTTP.Lucu.StatusCode.Internal
( StatusCode(..)
, SomeStatusCode
- , (≈)
- , (≉)
, statusCodes
)
where
import Data.Convertible.Base
import Data.Convertible.Instances.Ascii ()
import Data.Convertible.Utils
+import Data.Eq.Indirect
import Data.List
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
-- 'statusCodes' quasi-quoter.
--
-- Minimal complete definition: 'numericCode' and 'textualStatus'.
-class Show sc ⇒ StatusCode sc where
+class (Eq sc, 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
fromStatusCode ∷ sc → SomeStatusCode
fromStatusCode = SomeStatusCode
-instance StatusCode sc ⇒ Eq sc where
- (==) = (≈)
+-- |Equivalence of 'StatusCode's. Two 'StatusCode's @a@ and @b@ are
+-- said to be equivalent iff @'numericCode' a '==' 'numericCode' b@.
+instance StatusCode sc ⇒ Eq' sc where
+ type Unified sc = Int
+ {-# INLINE CONLIKE unify #-}
+ unify = numericCode
-- |Container type for the 'StatusCode' type class.
data SomeStatusCode
= ∀sc. StatusCode sc ⇒ SomeStatusCode sc
+instance Eq SomeStatusCode where
+ {-# INLINE CONLIKE (==) #-}
+ (==) = (≡:)
+
instance Show SomeStatusCode where
show (SomeStatusCode sc) = show sc
-infix 4 ≈, ≉
--- |Equivalence of 'StatusCode's. 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
-- becomes:
--
-- @
--- data OK = OK deriving ('Show')
+-- data OK = OK deriving ('Eq', 'Show')
-- instance OK where
-- 'numericCode' _ = 200
-- 'textualStatus' _ = 'cs' (\"200 OK\" ∷ Ascii)
--
--- data BadRequest = BadRequest deriving ('Show')
+-- data BadRequest = BadRequest deriving ('Eq', 'Show')
-- instance BadRequest where
-- 'numericCode' _ = 400
-- 'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii)
--
--- data MethodNotAllowed = MethodNotAllowed deriving ('Show')
+-- data MethodNotAllowed = MethodNotAllowed deriving ('Eq', 'Show')
-- instance MethodNotAllowed where
-- 'numericCode' _ = 405
-- 'textualStatus' _ = 'cs' (\"405 Method Not Allowed\" ∷ Ascii)
name = mkName $ concatMap cs phrase
dataDecl ∷ Q Dec
- dataDecl = dataD (cxt []) name [] [con] [''Show]
+ dataDecl = dataD (cxt []) name [] [con] [''Eq, ''Show]
instanceDecl ∷ Q [Dec]
instanceDecl
projects / Lucu.git / commitdiff