{-|
Module: Model.Types.Health
Description: Types for running self-tests
-}
module Model.Types.Health
  ( module Model.Types.Health
  ) where

import Import.NoModel


data HealthCheck
  = HealthCheckMatchingClusterConfig
  | HealthCheckHTTPReachable
  | HealthCheckLDAPAdmins
  | HealthCheckSMTPConnect
  | HealthCheckWidgetMemcached
  | HealthCheckActiveJobExecutors
  | HealthCheckDoesFlush
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe HealthCheck
instance Finite HealthCheck
instance Hashable HealthCheck
instance NFData HealthCheck

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 2
  } ''HealthCheck
nullaryPathPiece ''HealthCheck $ camelToPathPiece' 2
pathPieceJSONKey ''HealthCheck

data HealthReport
  = HealthMatchingClusterConfig { healthMatchingClusterConfig :: Bool }
    -- ^ Is the database-stored configuration we're running under still up to date?
    --
    -- Also tests database connection as a side effect
  | HealthHTTPReachable { healthHTTPReachable :: Maybe Bool }
    -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP?
  | HealthLDAPAdmins { healthLDAPAdmins :: Maybe Rational }
    -- ^ Proportion of school admins that could be found in LDAP
  | HealthSMTPConnect { healthSMTPConnect :: Maybe Bool }
    -- ^ Can we connect to the SMTP server and say @NOOP@?
  | HealthWidgetMemcached { healthWidgetMemcached :: Maybe Bool }
    -- ^ Can we store values in memcached and retrieve them via HTTP?
  | HealthActiveJobExecutors { healthActiveJobExecutors :: Maybe Rational }
    -- ^ Proportion of job executors (excluding the one running the healthcheck) responding within a timeout
  | HealthDoesFlush { healthFlushOverdue :: Maybe Rational }
  deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)

instance NFData HealthReport

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  , fieldLabelModifier = camelToPathPiece' 1
  , omitNothingFields  = True
  , sumEncoding = TaggedObject "test" "result"
  , tagSingleConstructors = True
  } ''HealthReport

classifyHealthReport :: HealthReport -> HealthCheck
classifyHealthReport HealthMatchingClusterConfig{} = HealthCheckMatchingClusterConfig
classifyHealthReport HealthLDAPAdmins{}            = HealthCheckLDAPAdmins
classifyHealthReport HealthHTTPReachable{}         = HealthCheckHTTPReachable
classifyHealthReport HealthSMTPConnect{}           = HealthCheckSMTPConnect
classifyHealthReport HealthWidgetMemcached{}       = HealthCheckWidgetMemcached
classifyHealthReport HealthActiveJobExecutors{}    = HealthCheckActiveJobExecutors
classifyHealthReport HealthDoesFlush{}             = HealthCheckDoesFlush

-- | `HealthReport` classified (`classifyHealthReport`) by badness
--
-- > a < b = a `worseThan` b
--
-- Currently all consumers of this type check for @(== HealthSuccess)@; this
-- needs to be adjusted on a case-by-case basis if new constructors are added
data HealthStatus = HealthFailure | HealthSuccess
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)

instance Universe HealthStatus
instance Finite HealthStatus

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  } ''HealthStatus
nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1

healthReportStatus :: HealthReport -> HealthStatus
-- ^ Classify `HealthReport` by badness
healthReportStatus = \case
  HealthMatchingClusterConfig       False  -> HealthFailure
  HealthHTTPReachable         (Just False) -> HealthFailure
  HealthLDAPAdmins            (Just prop )
    | prop <= 0                            -> HealthFailure
  HealthSMTPConnect           (Just False) -> HealthFailure
  HealthWidgetMemcached       (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully?
  HealthActiveJobExecutors    (Just prop )
    | prop <= 0                            -> HealthFailure
  HealthDoesFlush              mProp
    | maybe True (>= 2) mProp              -> HealthFailure
  _other                                   -> maxBound -- Minimum badness
