+++ /dev/null
-{-# LANGUAGE
- FlexibleContexts
- , TypeFamilies
- , UnicodeSyntax
- #-}
--- |Indirect equality comparison.
-module Data.Eq.Indirect
- ( Eq'(..)
- , (==:)
- , (/=:)
- , (≡:)
- , (≢:)
- , (≠:)
- )
- where
-import Prelude.Unicode
-
-infix 4 ==:, /=:, ≡:, ≢:, ≠:
-
--- |Type class for indirectly equality-comparable types. That is, any
--- @α@ of @'Eq'' α@ has a monomorphism to some
--- equality-comparable type @γ@ while @α@ itself isn't
--- necessarily an instance of 'Eq'. This way we can generalise the
--- '==' operator so that it can take two different types as long as
--- they both have monomorphisms to the same 'Eq' type @γ@.
---
--- Minimal complete definition: 'Unified' and 'unify'.
-class Eq (Unified α) ⇒ Eq' α where
- -- |The said equality-comparable type @γ@.
- type Unified α
- -- |Monomorphism from @α@ to @γ@.
- 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 ≡: MovedPermanently
+ | resStatus ≡ cs MovedPermanently
= do unsafeByteString "The resource at "
path
unsafeByteString " has been moved to "
a ! href (toValue loc) $ toHtml loc
unsafeByteString " permanently."
- | resStatus ≡: Found
+ | resStatus ≡ cs 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 ≡: SeeOther
+ | resStatus ≡ cs SeeOther
= do unsafeByteString "The resource at "
path
unsafeByteString " can be found at "
a ! href (toValue loc) $ toHtml loc
unsafeByteString "."
- | resStatus ≡: TemporaryRedirect
+ | resStatus ≡ cs TemporaryRedirect
= do unsafeByteString "The resource at "
path
unsafeByteString " is temporarily located at "
unsafeByteString "."
-- 4xx:
- | resStatus ≡: BadRequest
+ | resStatus ≡ cs BadRequest
= unsafeByteString "The server could not understand the request you sent."
- | resStatus ≡: Unauthorized
+ | resStatus ≡ cs Unauthorized
= unsafeByteString "You need a valid authentication to access " ⊕ path
- | resStatus ≡: Forbidden
+ | resStatus ≡ cs Forbidden
= unsafeByteString "You don't have permission to access " ⊕ path
- | resStatus ≡: NotFound
+ | resStatus ≡ cs NotFound
= do unsafeByteString "The requested URL "
path
unsafeByteString " was not found on this server."
- | resStatus ≡: Gone
+ | resStatus ≡ cs Gone
= do unsafeByteString "The resource at "
path
unsafeByteString " was here in past times, but has gone permanently."
- | resStatus ≡: RequestEntityTooLarge
+ | resStatus ≡ cs RequestEntityTooLarge
= do unsafeByteString "The request entity you sent for "
path
unsafeByteString " was too large to accept."
- | resStatus ≡: RequestURITooLarge
+ | resStatus ≡ cs RequestURITooLarge
= unsafeByteString "The request URI you sent was too large to accept."
-- 5xx:
- | resStatus ≡: InternalServerError
+ | resStatus ≡ cs InternalServerError
= unsafeByteString "An internal server error has occured during the process of your request to " ⊕ path
- | resStatus ≡: ServiceUnavailable
+ | resStatus ≡ cs 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 ≡: MethodNotAllowed ∧
- (¬) (hasHeader "Allow" res) )
+ when ( resStatus ≡ cs MethodNotAllowed ∧
+ (¬) (hasHeader "Allow" res) )
$ abort'
$ cs ("The status was " ∷ Ascii)
⊕ cs resStatus
⊕ cs (" but no \"Allow\" header." ∷ Ascii)
- when ( resStatus ≢: NotModified ∧
+ when ( resStatus ≢ cs NotModified ∧
isRedirection resStatus ∧
(¬) (hasHeader "Location" res) )
$ abort'
, QuasiQuotes
, RecordWildCards
, UnicodeSyntax
+ , ViewPatterns
#-}
-- |This is the Resource Monad; monadic actions to define a behavior
-- of resource. The 'Rsrc' Monad is a kind of 'IO' Monad thus it
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
-- \"Location\" header field as @uri@. The @code@ must satisfy
-- 'isRedirection' or it raises an error.
redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc ()
-redirect sc uri
- = do when (sc ≡: NotModified ∨ (¬) (isRedirection sc))
+redirect (fromStatusCode → sc) uri
+ = do when (sc ≡ cs NotModified ∨ (¬) (isRedirection sc))
$ abort
$ mkAbortion' InternalServerError
$ cs
$ ("Attempted to redirect with status " ∷ Ascii)
- ⊕ cs (fromStatusCode sc)
+ ⊕ cs sc
setStatus sc
setLocation uri
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
resCanHaveBody ∷ Response → Bool
{-# INLINEABLE resCanHaveBody #-}
resCanHaveBody (Response {..})
- | isInformational resStatus = False
- | resStatus ≡: NoContent = False
- | resStatus ≡: ResetContent = False
- | resStatus ≡: NotModified = False
- | otherwise = True
+ | isInformational resStatus = False
+ | resStatus ≡ cs NoContent = False
+ | resStatus ≡ cs ResetContent = False
+ | resStatus ≡ cs NotModified = False
+ | otherwise = True
-- |@'isInformational' sc@ returns 'True' iff @sc '<' 200@.
isInformational ∷ StatusCode sc ⇒ sc → Bool
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
fromStatusCode ∷ sc → SomeStatusCode
fromStatusCode = SomeStatusCode
--- |Equivalence of 'StatusCode's. Two 'StatusCode's @α@ and
--- @β@ are said to be equivalent iff @'numericCode' α '=='
--- 'numericCode' β@.
-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
-
-instance StatusCode SomeStatusCode where
- numericCode (SomeStatusCode sc) = numericCode sc
- textualStatus (SomeStatusCode sc) = textualStatus sc
- fromStatusCode = id
+instance StatusCode sc ⇒ ConvertSuccess sc SomeStatusCode where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = fromStatusCode
instance StatusCode sc ⇒ ConvertSuccess sc Ascii where
{-# INLINE convertSuccess #-}
{-# INLINE convertSuccess #-}
convertSuccess = textualStatus
+instance StatusCode sc ⇒ ConvertAttempt sc SomeStatusCode where
+ {-# INLINE convertAttempt #-}
+ convertAttempt = return ∘ cs
+
instance StatusCode sc ⇒ ConvertAttempt sc Ascii where
{-# INLINE convertAttempt #-}
convertAttempt = return ∘ cs
{-# INLINE convertAttempt #-}
convertAttempt = return ∘ cs
+-- |Container type for the 'StatusCode' type class.
+data SomeStatusCode
+ = ∀sc. StatusCode sc ⇒ SomeStatusCode sc
+
+-- |Equivalence of 'StatusCode's. Two 'StatusCode's @α@ and
+-- @β@ are said to be equivalent iff @'numericCode' α '=='
+-- 'numericCode' β@.
+instance Eq SomeStatusCode where
+ {-# INLINE (==) #-}
+ (==) = (∘ numericCode) ∘ (==) ∘ numericCode
+
+instance Show SomeStatusCode where
+ show (SomeStatusCode sc) = show sc
+
+instance StatusCode SomeStatusCode where
+ numericCode (SomeStatusCode sc) = numericCode sc
+ textualStatus (SomeStatusCode sc) = textualStatus sc
+ fromStatusCode = id
+
-- |'QuasiQuoter' for 'StatusCode' declarations.
--
-- Top-level splicing
projects / Lucu.git / commitdiff