132 lines
4.2 KiB
Haskell
132 lines
4.2 KiB
Haskell
{-# 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
|