{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeFamilies              #-}

-- | Defines the types and kinds for working with type and value level HTTP
-- status codes.
--
-- In particular, this module exports a datatype, 'Status' which is meant
-- to be used with @DataKinds@ providing one type, e.g. ''Ok' for every
-- common HTTP response status (and an override one 'CustomStatus'). It
-- also exports 'Sing' values for each 'Status'-kinded type each merely
-- being the name of that type prepended with @S@.
--
-- Finally, it exports a set of type synonms for each 'Status'-kinded type
-- so that they can be referenced without the quote prefix @'@.
module Network.HTTP.Kinder.Status (

  -- * Functions and types for working with 'HeaderName' 'Sing's
    SomeStatus (SomeStatus)
  , httpStatus
  , statusCode
  , parseStatus

  -- * The 'Status' type/kind
  , Status (..)
  , Sing (
      SCustomStatus
    , SContinue
    , SSwitchingProtocols
    , SOk
    , SCreated
    , SAccepted
    , SNonAuthoritiveInformation
    , SNoContent
    , SResetContent
    , SPartialContent
    , SIMUsed
    , SMultipleChoices
    , SMovedPermanently
    , SFound
    , SSeeOther
    , SNotModified
    , STemporaryRedirect
    , SPermanentRedirect
    , SBadRequest
    , SUnauthorized
    , SPaymentRequired
    , SForbidden
    , SNotFound
    , SMethodNotAllowed
    , SNotAcceptable
    , SProxyAuthenticationRequired
    , SRequestTimeout
    , SConflict
    , SGone
    , SLengthRequired
    , SPreconditionFailed
    , SPayloadTooLarge
    , SRequestURITooLong
    , SUnsupportedMediaType
    , SRequestedRangeNotSatisfiable
    , SExpectationFailed
    , SMisdirectedRequest
    , SUnprocessableEntity
    , SLocked
    , SFailedDependency
    , SUpgradeRequired
    , SPreconditionRequired
    , STooManyRequests
    , SRequestHeaderFieldsTooLarge
    , SUnavailableForLegalReasons
    , SInternalServerError
    , SNotImplemented
    , SBadGateway
    , SServiceUnavailable
    , SGatewayTimeout
    , SHTTPVersionNotSupported
    , SVariantAlsoNegotiates
    , SInsufficientStorage
    , SLoopDetected
    , SNotExtended
    , SNetworkAuthenticationRequired
  )

  -- * Type synonyms for more convenient use of 'Status'es

  , CustomStatus
  , Continue
  , SwitchingProtocols
  , Ok
  , Created
  , Accepted
  , NonAuthoritiveInformation
  , NoContent
  , ResetContent
  , PartialContent
  , IMUsed
  , MultipleChoices
  , MovedPermanently
  , Found
  , SeeOther
  , NotModified
  , TemporaryRedirect
  , PermanentRedirect
  , BadRequest
  , Unauthorized
  , PaymentRequired
  , Forbidden
  , NotFound
  , MethodNotAllowed
  , NotAcceptable
  , ProxyAuthenticationRequired
  , RequestTimeout
  , Conflict
  , Gone
  , LengthRequired
  , PreconditionFailed
  , PayloadTooLarge
  , RequestURITooLong
  , UnsupportedMediaType
  , RequestedRangeNotSatisfiable
  , ExpectationFailed
  , MisdirectedRequest
  , UnprocessableEntity
  , Locked
  , FailedDependency
  , UpgradeRequired
  , PreconditionRequired
  , TooManyRequests
  , RequestHeaderFieldsTooLarge
  , UnavailableForLegalReasons
  , InternalServerError
  , NotImplemented
  , BadGateway
  , ServiceUnavailable
  , GatewayTimeout
  , HTTPVersionNotSupported
  , VariantAlsoNegotiates
  , InsufficientStorage
  , LoopDetected
  , NotExtended
  , NetworkAuthenticationRequired

) where

import           Data.Singletons
import           Data.Singletons.TypeLits
import qualified Network.HTTP.Types.Status as S

-- | It's difficult to get ahold of values of 'Status' directly since they
-- may contain 'Nat' values which do not exist. Instead, we can get almost
-- the same effect through an existential which holds a singleton at the
-- 'Status' kind
--
-- Note that while the Haddocks show this as taking any 'Sing' type it is
-- actually constrained only to have 'Sing's of kind 'Status'.
data SomeStatus where
  SomeStatus :: forall (s :: Status) . Sing s -> SomeStatus

-- | Convert a 'Status' 'Sing'-value into a normal @http-types@ 'S.Status'
httpStatus :: forall (sc :: Status) . Sing sc -> S.Status
httpStatus c =
  case c of
    SCustomStatus int -> S.mkStatus (fromInteger (withKnownNat int (natVal int))) ""

    SContinue -> S.status100
    SSwitchingProtocols -> S.status101

    SOk -> S.status200
    SCreated -> S.status201
    SAccepted -> S.status202
    SNonAuthoritiveInformation -> S.status203
    SNoContent -> S.status204
    SResetContent -> S.status205
    SPartialContent -> S.status206
    SIMUsed -> S.mkStatus 226 "IM Used"

    SMultipleChoices -> S.status300
    SMovedPermanently -> S.status301
    SFound -> S.status302
    SSeeOther -> S.status303
    SNotModified -> S.status304
    STemporaryRedirect -> S.status307
    SPermanentRedirect -> S.status308

    SBadRequest -> S.status400
    SUnauthorized -> S.status401
    SPaymentRequired -> S.status402
    SForbidden -> S.status403
    SNotFound -> S.status404
    SMethodNotAllowed -> S.status405
    SNotAcceptable -> S.status406
    SProxyAuthenticationRequired -> S.status407
    SRequestTimeout -> S.status408
    SConflict -> S.status409
    SGone -> S.status410
    SLengthRequired -> S.status411
    SPreconditionFailed -> S.status412
    SPayloadTooLarge -> S.status413
    SRequestURITooLong -> S.status414
    SUnsupportedMediaType -> S.status415
    SRequestedRangeNotSatisfiable -> S.status416
    SExpectationFailed -> S.status417
    SMisdirectedRequest -> S.mkStatus 421 "Misdirected Request"
    SUnprocessableEntity -> S.mkStatus 422 "Unprocessable Entity"
    SLocked -> S.mkStatus 423 "Locked"
    SFailedDependency -> S.mkStatus 424 "Failed Dependency"
    SUpgradeRequired -> S.mkStatus 426 "Upgrade Required"
    SPreconditionRequired -> S.status428
    STooManyRequests -> S.status429
    SRequestHeaderFieldsTooLarge -> S.status431
    SUnavailableForLegalReasons -> S.mkStatus 451 "Unavailable for Legal Reasons"

    SInternalServerError -> S.status500
    SNotImplemented -> S.status501
    SBadGateway -> S.status502
    SServiceUnavailable -> S.status503
    SGatewayTimeout -> S.status504
    SHTTPVersionNotSupported -> S.status505
    SVariantAlsoNegotiates -> S.mkStatus 506 "Variant Also Negotiates"
    SInsufficientStorage -> S.mkStatus 507 "Insufficient Storage"
    SLoopDetected -> S.mkStatus 508 "Loop Detected"
    SNotExtended -> S.mkStatus 510 "Not Extended"
    SNetworkAuthenticationRequired -> S.status511

-- | Get the 'Int' status code for a given 'Status' 'Sing'.
statusCode :: forall (sc :: Status) . Sing sc -> Int
statusCode = S.statusCode . httpStatus

-- | Given a particular 'Int' status create a 'Status' 'Sing' to match.
-- Attempts to parse to a meaningful 'Status' 'Sing' but defaults to
-- 'CustomStatus' if necessary.
parseStatus :: Int -> SomeStatus
parseStatus c =
  case c of
    100 -> SomeStatus SContinue
    101 -> SomeStatus SSwitchingProtocols

    200 -> SomeStatus SOk
    201 -> SomeStatus SCreated
    202 -> SomeStatus SAccepted
    204 -> SomeStatus SNoContent
    205 -> SomeStatus SResetContent
    206 -> SomeStatus SPartialContent
    226 -> SomeStatus SIMUsed

    300 -> SomeStatus SMultipleChoices
    301 -> SomeStatus SMovedPermanently
    302 -> SomeStatus SFound
    303 -> SomeStatus SSeeOther
    304 -> SomeStatus SNotModified
    307 -> SomeStatus STemporaryRedirect
    308 -> SomeStatus SPermanentRedirect

    400 -> SomeStatus SBadRequest
    401 -> SomeStatus SUnauthorized
    402 -> SomeStatus SPaymentRequired
    403 -> SomeStatus SForbidden
    404 -> SomeStatus SNotFound
    405 -> SomeStatus SMethodNotAllowed
    406 -> SomeStatus SNotAcceptable
    407 -> SomeStatus SProxyAuthenticationRequired
    408 -> SomeStatus SRequestTimeout
    409 -> SomeStatus SConflict
    410 -> SomeStatus SGone
    411 -> SomeStatus SLengthRequired
    412 -> SomeStatus SPreconditionFailed
    413 -> SomeStatus SPayloadTooLarge
    414 -> SomeStatus SRequestURITooLong
    415 -> SomeStatus SUnsupportedMediaType
    416 -> SomeStatus SRequestedRangeNotSatisfiable
    417 -> SomeStatus SExpectationFailed
    421 -> SomeStatus SMisdirectedRequest
    422 -> SomeStatus SUnprocessableEntity
    423 -> SomeStatus SLocked
    424 -> SomeStatus SFailedDependency
    426 -> SomeStatus SUpgradeRequired
    428 -> SomeStatus SPreconditionRequired
    429 -> SomeStatus STooManyRequests
    431 -> SomeStatus SRequestHeaderFieldsTooLarge
    451 -> SomeStatus SUnavailableForLegalReasons

    500 -> SomeStatus SInternalServerError
    501 -> SomeStatus SNotImplemented
    502 -> SomeStatus SBadGateway
    503 -> SomeStatus SServiceUnavailable
    504 -> SomeStatus SGatewayTimeout
    505 -> SomeStatus SHTTPVersionNotSupported
    506 -> SomeStatus SVariantAlsoNegotiates
    507 -> SomeStatus SInsufficientStorage
    508 -> SomeStatus SLoopDetected
    510 -> SomeStatus SNotExtended
    511 -> SomeStatus SNetworkAuthenticationRequired

    other ->
      case toSing (fromIntegral other) :: SomeSing ('KProxy :: KProxy Nat) of
        SomeSing code -> SomeStatus (SCustomStatus code)

-- | A data type representing HTTP statuses (codes). Much more importantly,
-- with @DataKinds@ enabled this becomes a kind describing types, one for
-- each such status.
--
-- It's worth noting that values of this type can be had, but one branch,
-- 'CustomStatus' will not work since it requires 'Nat' values which cannot
-- be had. For this reason prefer using values of 'SomeStatus' instead of
-- values of 'Status' directly.
data Status

  ---- Custom codes

  = CustomStatus Nat
    -- ^ Inject an arbitatry code number as a status code.

  ---- 1xx Informational

  | Continue
  | SwitchingProtocols

  ---- 2xx Success

  | Ok
  | Created
  | Accepted
  | NonAuthoritiveInformation
  | NoContent
  | ResetContent
  | PartialContent
  | IMUsed

  ---- 3xx Redirection

  | MultipleChoices
  | MovedPermanently
  | Found
  | SeeOther
  | NotModified
  | TemporaryRedirect
  | PermanentRedirect

  ---- 4xx Client Error

  | BadRequest
  | Unauthorized
  | PaymentRequired
  | Forbidden
  | NotFound
  | MethodNotAllowed
  | NotAcceptable
  | ProxyAuthenticationRequired
  | RequestTimeout
  | Conflict
  | Gone
  | LengthRequired
  | PreconditionFailed
  | PayloadTooLarge
  | RequestURITooLong
  | UnsupportedMediaType
  | RequestedRangeNotSatisfiable
  | ExpectationFailed
  | MisdirectedRequest
  | UnprocessableEntity
  | Locked
  | FailedDependency
  | UpgradeRequired
  | PreconditionRequired
  | TooManyRequests
  | RequestHeaderFieldsTooLarge
  | UnavailableForLegalReasons

  ---- 5xx Server Error

  | InternalServerError
  | NotImplemented
  | BadGateway
  | ServiceUnavailable
  | GatewayTimeout
  | HTTPVersionNotSupported
  | VariantAlsoNegotiates
  | InsufficientStorage
  | LoopDetected
  | NotExtended
  | NetworkAuthenticationRequired

type CustomStatus code = 'CustomStatus code
type Continue = 'Continue
type SwitchingProtocols = 'SwitchingProtocols
type Ok = 'Ok
type Created = 'Created
type Accepted = 'Accepted
type NonAuthoritiveInformation = 'NonAuthoritiveInformation
type NoContent = 'NoContent
type ResetContent = 'ResetContent
type PartialContent = 'PartialContent
type IMUsed = 'IMUsed
type MultipleChoices = 'MultipleChoices
type MovedPermanently = 'MovedPermanently
type Found = 'Found
type SeeOther = 'SeeOther
type NotModified = 'NotModified
type TemporaryRedirect = 'TemporaryRedirect
type PermanentRedirect = 'PermanentRedirect
type BadRequest = 'BadRequest
type Unauthorized = 'Unauthorized
type PaymentRequired = 'PaymentRequired
type Forbidden = 'Forbidden
type NotFound = 'NotFound
type MethodNotAllowed = 'MethodNotAllowed
type NotAcceptable = 'NotAcceptable
type ProxyAuthenticationRequired = 'ProxyAuthenticationRequired
type RequestTimeout = 'RequestTimeout
type Conflict = 'Conflict
type Gone = 'Gone
type LengthRequired = 'LengthRequired
type PreconditionFailed = 'PreconditionFailed
type PayloadTooLarge = 'PayloadTooLarge
type RequestURITooLong = 'RequestURITooLong
type UnsupportedMediaType = 'UnsupportedMediaType
type RequestedRangeNotSatisfiable = 'RequestedRangeNotSatisfiable
type ExpectationFailed = 'ExpectationFailed
type MisdirectedRequest = 'MisdirectedRequest
type UnprocessableEntity = 'UnprocessableEntity
type Locked = 'Locked
type FailedDependency = 'FailedDependency
type UpgradeRequired = 'UpgradeRequired
type PreconditionRequired = 'PreconditionRequired
type TooManyRequests = 'TooManyRequests
type RequestHeaderFieldsTooLarge = 'RequestHeaderFieldsTooLarge
type UnavailableForLegalReasons = 'UnavailableForLegalReasons
type InternalServerError = 'InternalServerError
type NotImplemented = 'NotImplemented
type BadGateway = 'BadGateway
type ServiceUnavailable = 'ServiceUnavailable
type GatewayTimeout = 'GatewayTimeout
type HTTPVersionNotSupported = 'HTTPVersionNotSupported
type VariantAlsoNegotiates = 'VariantAlsoNegotiates
type InsufficientStorage = 'InsufficientStorage
type LoopDetected = 'LoopDetected
type NotExtended = 'NotExtended
type NetworkAuthenticationRequired = 'NetworkAuthenticationRequired

-- ----------------------------------------------------------------------------
-- These could be generated by TH, but we're inlining them! Not only is
-- this faster but it also properly handles the fact that there is no
-- reasonable 'DemoteRep' available
-- ----------------------------------------------------------------------------

data instance Sing (s :: Status)
  = forall i . s ~ CustomStatus i => SCustomStatus (Sing i)
  | s ~ Continue => SContinue
  | s ~ SwitchingProtocols => SSwitchingProtocols
  | s ~ Ok => SOk
  | s ~ Created => SCreated
  | s ~ Accepted => SAccepted
  | s ~ NonAuthoritiveInformation => SNonAuthoritiveInformation
  | s ~ NoContent => SNoContent
  | s ~ ResetContent => SResetContent
  | s ~ PartialContent => SPartialContent
  | s ~ IMUsed => SIMUsed
  | s ~ MultipleChoices => SMultipleChoices
  | s ~ MovedPermanently => SMovedPermanently
  | s ~ Found => SFound
  | s ~ SeeOther => SSeeOther
  | s ~ NotModified => SNotModified
  | s ~ TemporaryRedirect => STemporaryRedirect
  | s ~ PermanentRedirect => SPermanentRedirect
  | s ~ BadRequest => SBadRequest
  | s ~ Unauthorized => SUnauthorized
  | s ~ PaymentRequired => SPaymentRequired
  | s ~ Forbidden => SForbidden
  | s ~ NotFound => SNotFound
  | s ~ MethodNotAllowed => SMethodNotAllowed
  | s ~ NotAcceptable => SNotAcceptable
  | s ~ ProxyAuthenticationRequired => SProxyAuthenticationRequired
  | s ~ RequestTimeout => SRequestTimeout
  | s ~ Conflict => SConflict
  | s ~ Gone => SGone
  | s ~ LengthRequired => SLengthRequired
  | s ~ PreconditionFailed => SPreconditionFailed
  | s ~ PayloadTooLarge => SPayloadTooLarge
  | s ~ RequestURITooLong => SRequestURITooLong
  | s ~ UnsupportedMediaType => SUnsupportedMediaType
  | s ~ RequestedRangeNotSatisfiable => SRequestedRangeNotSatisfiable
  | s ~ ExpectationFailed => SExpectationFailed
  | s ~ MisdirectedRequest => SMisdirectedRequest
  | s ~ UnprocessableEntity => SUnprocessableEntity
  | s ~ Locked => SLocked
  | s ~ FailedDependency => SFailedDependency
  | s ~ UpgradeRequired => SUpgradeRequired
  | s ~ PreconditionRequired => SPreconditionRequired
  | s ~ TooManyRequests => STooManyRequests
  | s ~ RequestHeaderFieldsTooLarge => SRequestHeaderFieldsTooLarge
  | s ~ UnavailableForLegalReasons => SUnavailableForLegalReasons
  | s ~ InternalServerError => SInternalServerError
  | s ~ NotImplemented => SNotImplemented
  | s ~ BadGateway => SBadGateway
  | s ~ ServiceUnavailable => SServiceUnavailable
  | s ~ GatewayTimeout => SGatewayTimeout
  | s ~ HTTPVersionNotSupported => SHTTPVersionNotSupported
  | s ~ VariantAlsoNegotiates => SVariantAlsoNegotiates
  | s ~ InsufficientStorage => SInsufficientStorage
  | s ~ LoopDetected => SLoopDetected
  | s ~ NotExtended => SNotExtended
  | s ~ NetworkAuthenticationRequired => SNetworkAuthenticationRequired

instance SingI i => SingI ('CustomStatus i) where sing = SCustomStatus sing
instance SingI 'Continue where sing = SContinue
instance SingI 'SwitchingProtocols where sing = SSwitchingProtocols
instance SingI 'Ok where sing = SOk
instance SingI 'Created where sing = SCreated
instance SingI 'Accepted where sing = SAccepted
instance SingI 'NonAuthoritiveInformation where sing = SNonAuthoritiveInformation
instance SingI 'NoContent where sing = SNoContent
instance SingI 'ResetContent where sing = SResetContent
instance SingI 'PartialContent where sing = SPartialContent
instance SingI 'IMUsed where sing = SIMUsed
instance SingI 'MultipleChoices where sing = SMultipleChoices
instance SingI 'MovedPermanently where sing = SMovedPermanently
instance SingI 'Found where sing = SFound
instance SingI 'SeeOther where sing = SSeeOther
instance SingI 'NotModified where sing = SNotModified
instance SingI 'TemporaryRedirect where sing = STemporaryRedirect
instance SingI 'PermanentRedirect where sing = SPermanentRedirect
instance SingI 'BadRequest where sing = SBadRequest
instance SingI 'Unauthorized where sing = SUnauthorized
instance SingI 'PaymentRequired where sing = SPaymentRequired
instance SingI 'Forbidden where sing = SForbidden
instance SingI 'NotFound where sing = SNotFound
instance SingI 'MethodNotAllowed where sing = SMethodNotAllowed
instance SingI 'NotAcceptable where sing = SNotAcceptable
instance SingI 'ProxyAuthenticationRequired where sing = SProxyAuthenticationRequired
instance SingI 'RequestTimeout where sing = SRequestTimeout
instance SingI 'Conflict where sing = SConflict
instance SingI 'Gone where sing = SGone
instance SingI 'LengthRequired where sing = SLengthRequired
instance SingI 'PreconditionFailed where sing = SPreconditionFailed
instance SingI 'PayloadTooLarge where sing = SPayloadTooLarge
instance SingI 'RequestURITooLong where sing = SRequestURITooLong
instance SingI 'UnsupportedMediaType where sing = SUnsupportedMediaType
instance SingI 'RequestedRangeNotSatisfiable where sing = SRequestedRangeNotSatisfiable
instance SingI 'ExpectationFailed where sing = SExpectationFailed
instance SingI 'MisdirectedRequest where sing = SMisdirectedRequest
instance SingI 'UnprocessableEntity where sing = SUnprocessableEntity
instance SingI 'Locked where sing = SLocked
instance SingI 'FailedDependency where sing = SFailedDependency
instance SingI 'UpgradeRequired where sing = SUpgradeRequired
instance SingI 'PreconditionRequired where sing = SPreconditionRequired
instance SingI 'TooManyRequests where sing = STooManyRequests
instance SingI 'RequestHeaderFieldsTooLarge where sing = SRequestHeaderFieldsTooLarge
instance SingI 'UnavailableForLegalReasons where sing = SUnavailableForLegalReasons
instance SingI 'InternalServerError where sing = SInternalServerError
instance SingI 'NotImplemented where sing = SNotImplemented
instance SingI 'BadGateway where sing = SBadGateway
instance SingI 'ServiceUnavailable where sing = SServiceUnavailable
instance SingI 'GatewayTimeout where sing = SGatewayTimeout
instance SingI 'HTTPVersionNotSupported where sing = SHTTPVersionNotSupported
instance SingI 'VariantAlsoNegotiates where sing = SVariantAlsoNegotiates
instance SingI 'InsufficientStorage where sing = SInsufficientStorage
instance SingI 'LoopDetected where sing = SLoopDetected
instance SingI 'NotExtended where sing = SNotExtended
instance SingI 'NetworkAuthenticationRequired where sing = SNetworkAuthenticationRequired