{-# OPTIONS_GHC -fno-warn-orphans #-}

module Settings.Cluster
  ( ClusterSettingsKey(..)
  , ClusterSetting(..)
  ) where

import ClassyPrelude.Yesod
import Web.HttpApiData

import Utils
import Data.Universe

import qualified Data.Aeson as Aeson

import qualified Crypto.Saltine.Core.SecretBox as SecretBox
import qualified Crypto.Saltine.Core.AEAD as AEAD
import qualified Crypto.Saltine.Class as Saltine

import Data.CryptoID.ByteString (CryptoIDKey)
import qualified Data.CryptoID.ByteString as CryptoID

import qualified Data.Binary as Binary
import qualified Data.ByteString.Base64.URL as Base64

import qualified Jose.Jwa as Jose
import qualified Jose.Jwk as Jose
import qualified Jose.Jwt as Jose

import Data.UUID (UUID)
import Control.Monad.Random.Class (MonadRandom(..))

import Control.Monad.Fail

import Model.Types.TH.PathPiece


data ClusterSettingsKey
  = ClusterCryptoIDKey
  | ClusterServerSessionKey
  | ClusterSecretBoxKey
  | ClusterJSONWebKeySet
  | ClusterId
  | ClusterMemcachedKey
  deriving (Eq, Ord, Enum, Bounded, Show, Read)

instance Universe ClusterSettingsKey
instance Finite ClusterSettingsKey

nullaryPathPiece ''ClusterSettingsKey $ camelToPathPiece' 1
pathPieceJSON ''ClusterSettingsKey
pathPieceJSONKey ''ClusterSettingsKey
derivePersistFieldPathPiece ''ClusterSettingsKey

instance ToHttpApiData ClusterSettingsKey where
  toUrlPiece = toPathPiece
instance FromHttpApiData ClusterSettingsKey where
  parseUrlPiece = maybe (Left "Could not parse url piece") Right . fromPathPiece

  
class (ToJSON (ClusterSettingValue key), FromJSON (ClusterSettingValue key)) => ClusterSetting (key :: ClusterSettingsKey) where
  type ClusterSettingValue key :: *
  initClusterSetting :: forall m p. MonadIO m => p key -> m (ClusterSettingValue key)
  knownClusterSetting :: forall p. p key -> ClusterSettingsKey


instance ClusterSetting 'ClusterCryptoIDKey where
  type ClusterSettingValue 'ClusterCryptoIDKey = CryptoIDKey
  initClusterSetting _ = CryptoID.genKey
  knownClusterSetting _ = ClusterCryptoIDKey

instance ToJSON CryptoIDKey where
  toJSON = Aeson.String . decodeUtf8 . Base64.encode . toStrict . Binary.encode

instance FromJSON CryptoIDKey where
  parseJSON = Aeson.withText "CryptoIDKey" $ \t -> do
    bytes <- either fail (return . fromStrict) . Base64.decode $ encodeUtf8 t
    case Binary.decodeOrFail bytes of
      Left (_, _, err) -> fail err
      Right (bs, _, ret)
        | null bs -> return ret
        | otherwise -> fail $ show (length bs) ++ " extra bytes"


instance ClusterSetting 'ClusterServerSessionKey where
  type ClusterSettingValue 'ClusterServerSessionKey = AEAD.Key
  initClusterSetting _ = liftIO AEAD.newKey
  knownClusterSetting _ = ClusterServerSessionKey
  
instance ToJSON AEAD.Key where
  toJSON = Aeson.String . decodeUtf8 . Base64.encode . Saltine.encode

instance FromJSON AEAD.Key where
  parseJSON = Aeson.withText "Key" $ \t -> do
    bytes <- either fail return . Base64.decode $ encodeUtf8 t
    maybe (fail "Could not parse key") return $ Saltine.decode bytes


instance ClusterSetting 'ClusterSecretBoxKey where
  type ClusterSettingValue 'ClusterSecretBoxKey = SecretBox.Key
  initClusterSetting _ = liftIO SecretBox.newKey
  knownClusterSetting _ = ClusterSecretBoxKey

instance ToJSON SecretBox.Key where
  toJSON = Aeson.String . decodeUtf8 . Base64.encode . Saltine.encode

instance FromJSON SecretBox.Key where
  parseJSON = Aeson.withText "Key" $ \t -> do
    bytes <- either fail return . Base64.decode $ encodeUtf8 t
    maybe (fail "Could not parse key") return $ Saltine.decode bytes


instance ClusterSetting 'ClusterJSONWebKeySet where
  type ClusterSettingValue 'ClusterJSONWebKeySet = Jose.JwkSet
  initClusterSetting _ = liftIO $ do
    now <- getCurrentTime
    jwkSig <- Jose.generateSymmetricKey 32 (Jose.UTCKeyId now) Jose.Sig (Just $ Jose.Signed Jose.HS256)
    return $ Jose.JwkSet [jwkSig]
  knownClusterSetting _ = ClusterJSONWebKeySet


instance ClusterSetting 'ClusterId where
  type ClusterSettingValue 'ClusterId = UUID
  initClusterSetting _ = liftIO getRandom
  knownClusterSetting _ = ClusterId


instance ClusterSetting 'ClusterMemcachedKey where
  type ClusterSettingValue 'ClusterMemcachedKey = AEAD.Key
  initClusterSetting _ = liftIO AEAD.newKey
  knownClusterSetting _ = ClusterMemcachedKey