fradrive-old/src/Settings/Cluster.hs

-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

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

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

import ClassyPrelude.Yesod

import Data.Kind (Type)

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.Core.Auth as Auth
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

import Data.ByteArray (ByteArray, ByteArrayAccess)
import qualified Crypto.Random as Crypto

import Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey, newPersonalisedSheetFilesSeedKey)


data ClusterSettingsKey
  = ClusterCryptoIDKey
  | ClusterServerSessionKey
  | ClusterSecretBoxKey
  | ClusterJSONWebKeySet
  | ClusterId
  | ClusterMemcachedKey
  | ClusterVerpSecret
  | ClusterAuthKey
  | ClusterPersonalisedSheetFilesSeedKey
  deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
  deriving anyclass (Universe, Finite, NFData)

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


class (ToJSON (ClusterSettingValue key), FromJSON (ClusterSettingValue key)) => ClusterSetting (key :: ClusterSettingsKey) where
  type ClusterSettingValue key :: Type
  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 "AEAD.Key" $ \t -> do
    bytes <- either fail return . Base64.decode $ encodeUtf8 t
    maybe (fail "Could not parse AEAD.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 "SecretBox.Key" $ \t -> do
    bytes <- either fail return . Base64.decode $ encodeUtf8 t
    maybe (fail "Could not parse SecretBox.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


newtype VerpSecret = VerpSecret ByteString
  deriving newtype (Eq, Ord, Monoid, Semigroup, ByteArray, ByteArrayAccess)

instance ToJSON VerpSecret where
  toJSON (VerpSecret vSecret) = Aeson.String . decodeUtf8 $ Base64.encode vSecret
instance FromJSON VerpSecret where
  parseJSON = Aeson.withText "VerpSecret" $ \t -> do
    bytes <- either fail return . Base64.decode $ encodeUtf8 t
    return $ VerpSecret bytes

instance ClusterSetting 'ClusterVerpSecret where
  type ClusterSettingValue 'ClusterVerpSecret = VerpSecret
  initClusterSetting _ = liftIO $ Crypto.getRandomBytes 16
  knownClusterSetting _ = ClusterVerpSecret

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

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

instance ClusterSetting 'ClusterAuthKey where
  type ClusterSettingValue 'ClusterAuthKey = Auth.Key
  initClusterSetting _ = liftIO Auth.newKey
  knownClusterSetting _ = ClusterAuthKey


instance ClusterSetting 'ClusterPersonalisedSheetFilesSeedKey where
  type ClusterSettingValue 'ClusterPersonalisedSheetFilesSeedKey = PersonalisedSheetFilesSeedKey
  initClusterSetting _ = liftIO newPersonalisedSheetFilesSeedKey
  knownClusterSetting _ = ClusterPersonalisedSheetFilesSeedKey