{-# LANGUAGE DuplicateRecordFields #-}

-- |
--
-- Module      : Kubernetes.Webhook
-- Copyright   : (c) Earnest Research, 2020
-- License     : MIT
-- Maintainer  : amarrella@earnestresearch.com
-- Stability   : experimental
-- Portability : POSIX
--
-- This module lets you create [Kubernetes Admission Webhooks](https://kubernetes.io/docs/reference/access-authn-authz/extensible-admission-controllers/).
--
-- Example with Servant (note: webhooks in Kubernetes require TLS):
--
-- @
--   module Kubernetes.Example
--       ( startApp,
--         app,
--       )
--     where
--
--   import Control.Monad.IO.Class
--   import qualified Data.Aeson as A
--   import qualified Data.ByteString as BS
--   import qualified Data.HashMap.Strict as HM
--   import Data.Text
--   import GHC.Generics
--   import qualified Kubernetes.Webhook as W
--   import Network.Wai
--   import Network.Wai.Handler.Warp
--   import Network.Wai.Handler.WarpTLS
--   import Servant
--   import System.Environment
--
--   type API =
--     "mutate" :> ReqBody '[JSON] W.AdmissionReviewRequest :> Post '[JSON] W.AdmissionReviewResponse
--
--   data Toleration
--     = Toleration
--         { effect :: Maybe TolerationEffect,
--           key :: Maybe Text,
--           operator :: Maybe TolerationOperator,
--           tolerationSeconds :: Maybe Integer,
--           value :: Maybe Text
--         }
--     deriving (Generic, A.ToJSON)
--
--   data TolerationEffect = NoSchedule | PreferNoSchedule | NoExecute deriving (Generic, A.ToJSON)
--
--   data TolerationOperator = Exists | Equal deriving (Generic, A.ToJSON)
--
--   testToleration :: Toleration
--   testToleration =
--     Toleration
--       { effect = Just NoSchedule,
--         key = Just "dedicated",
--         operator = Just Equal,
--         tolerationSeconds = Nothing,
--         value = Just "test"
--       }
--
--   startApp :: IO ()
--   startApp = do
--     let tlsOpts = tlsSettings "/certs/tls.crt" "/certs/tls.key"
--         warpOpts = setPort 8080 defaultSettings
--     runTLS tlsOpts warpOpts app
--
--   app :: Application
--   app = serve api server
--
--   api :: Proxy API
--   api = Proxy
--
--   server :: Server API
--   server = mutate
--
--   mutate :: W.AdmissionReviewRequest -> Handler W.AdmissionReviewResponse
--   mutate req = pure $ W.mutatingWebhook req (\_ -> Right addToleration)
--
--   addToleration :: W.Patch
--   addToleration =
--     W.Patch
--       [ W.PatchOperation
--           { op = W.Add,
--             path = "/spec/tolerations/-",
--             from = Nothing,
--             value = Just $ A.toJSON testToleration
--           }
--       ]
-- @
module Kubernetes.Webhook
  ( mutatingWebhook,
    validatingWebhook,
    Allowed (..),
    module Kubernetes.Webhook.Types,
  )
where

import Data.Either
import Kubernetes.Webhook.Types

data Allowed = Allowed

-- | Lets you create a mutating admission webhook
mutatingWebhook ::
  -- | the request the webhook receives from Kubernetes
  AdmissionReviewRequest ->
  -- | logic to validate the request by returning the change to apply to the object or reject the request with an error
  (AdmissionRequest -> Either Status Patch) ->
  -- | the response sent back to Kubernetes
  AdmissionReviewResponse
mutatingWebhook :: AdmissionReviewRequest
-> (AdmissionRequest -> Either Status Patch)
-> AdmissionReviewResponse
mutatingWebhook AdmissionReviewRequest {$sel:request:AdmissionReviewRequest :: AdmissionReviewRequest -> AdmissionRequest
request = AdmissionRequest
req} mutator :: AdmissionRequest -> Either Status Patch
mutator =
  AdmissionResponse -> AdmissionReviewResponse
admissionReviewResponse $WAdmissionResponse :: UID
-> Bool
-> Maybe Status
-> Maybe Patch
-> Maybe PatchType
-> Maybe (HashMap Text [Text])
-> AdmissionResponse
AdmissionResponse
    { $sel:uid:AdmissionResponse :: UID
uid = UID
rid,
      $sel:allowed:AdmissionResponse :: Bool
allowed = Either Status Patch -> Bool
forall a b. Either a b -> Bool
isRight Either Status Patch
processedRequest,
      $sel:patch:AdmissionResponse :: Maybe Patch
patch = (Status -> Maybe Patch)
-> (Patch -> Maybe Patch) -> Either Status Patch -> Maybe Patch
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Patch -> Status -> Maybe Patch
forall a b. a -> b -> a
const Maybe Patch
forall a. Maybe a
Nothing) Patch -> Maybe Patch
forall a. a -> Maybe a
Just Either Status Patch
processedRequest,
      $sel:status:AdmissionResponse :: Maybe Status
status = (Status -> Maybe Status)
-> (Patch -> Maybe Status) -> Either Status Patch -> Maybe Status
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Status -> Maybe Status
forall a. a -> Maybe a
Just (Maybe Status -> Patch -> Maybe Status
forall a b. a -> b -> a
const Maybe Status
forall a. Maybe a
Nothing) Either Status Patch
processedRequest,
      $sel:patchType:AdmissionResponse :: Maybe PatchType
patchType = PatchType -> Maybe PatchType
forall a. a -> Maybe a
Just PatchType
JSONPatch,
      $sel:auditAnnotations:AdmissionResponse :: Maybe (HashMap Text [Text])
auditAnnotations = Maybe (HashMap Text [Text])
forall a. Maybe a
Nothing
    }
  where
    AdmissionRequest {$sel:uid:AdmissionRequest :: AdmissionRequest -> UID
uid = UID
rid} = AdmissionRequest
req
    processedRequest :: Either Status Patch
processedRequest = AdmissionRequest -> Either Status Patch
mutator AdmissionRequest
req

-- | Lets you create a validating admission webhook
validatingWebhook ::
  -- | the request the webhook receives from Kubernetes
  AdmissionReviewRequest ->
  -- | logic to validate the request or reject it with an error
  (AdmissionRequest -> Either Status Allowed) ->
  -- | the response sent back to Kubernetes
  AdmissionReviewResponse
validatingWebhook :: AdmissionReviewRequest
-> (AdmissionRequest -> Either Status Allowed)
-> AdmissionReviewResponse
validatingWebhook AdmissionReviewRequest {$sel:request:AdmissionReviewRequest :: AdmissionReviewRequest -> AdmissionRequest
request = AdmissionRequest
req} allow :: AdmissionRequest -> Either Status Allowed
allow =
  AdmissionResponse -> AdmissionReviewResponse
admissionReviewResponse $WAdmissionResponse :: UID
-> Bool
-> Maybe Status
-> Maybe Patch
-> Maybe PatchType
-> Maybe (HashMap Text [Text])
-> AdmissionResponse
AdmissionResponse
    { $sel:uid:AdmissionResponse :: UID
uid = UID
rid,
      $sel:allowed:AdmissionResponse :: Bool
allowed = Either Status Allowed -> Bool
forall a b. Either a b -> Bool
isRight Either Status Allowed
processedRequest,
      $sel:patch:AdmissionResponse :: Maybe Patch
patch = Maybe Patch
forall a. Maybe a
Nothing,
      $sel:status:AdmissionResponse :: Maybe Status
status = (Status -> Maybe Status)
-> (Allowed -> Maybe Status)
-> Either Status Allowed
-> Maybe Status
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Status -> Maybe Status
forall a. a -> Maybe a
Just (Maybe Status -> Allowed -> Maybe Status
forall a b. a -> b -> a
const Maybe Status
forall a. Maybe a
Nothing) Either Status Allowed
processedRequest,
      $sel:patchType:AdmissionResponse :: Maybe PatchType
patchType = Maybe PatchType
forall a. Maybe a
Nothing,
      $sel:auditAnnotations:AdmissionResponse :: Maybe (HashMap Text [Text])
auditAnnotations = Maybe (HashMap Text [Text])
forall a. Maybe a
Nothing
    }
  where
    AdmissionRequest {$sel:uid:AdmissionRequest :: AdmissionRequest -> UID
uid = UID
rid} = AdmissionRequest
req
    processedRequest :: Either Status Allowed
processedRequest = AdmissionRequest -> Either Status Allowed
allow AdmissionRequest
req