147 lines
4.8 KiB
Haskell
147 lines
4.8 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Settings.Cluster
|
|
( ClusterSettingsKey(..)
|
|
, ClusterSetting(..)
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod
|
|
import Database.Persist.Sql
|
|
import Web.HttpApiData
|
|
|
|
import Utils
|
|
import Control.Lens
|
|
import Data.Universe
|
|
|
|
import Data.Aeson ( FromJSON(..), ToJSON(..)
|
|
, Options(..), defaultOptions
|
|
, FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..)
|
|
)
|
|
import Data.Aeson.TH (deriveJSON)
|
|
import Data.Aeson.Types (toJSONKeyText)
|
|
import qualified Data.Aeson as Aeson
|
|
|
|
import qualified Web.ClientSession as ClientSession
|
|
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
|
|
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.Serialize as Serialize
|
|
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(..))
|
|
|
|
|
|
data ClusterSettingsKey
|
|
= ClusterCryptoIDKey
|
|
| ClusterClientSessionKey
|
|
| ClusterSecretBoxKey
|
|
| ClusterJSONWebKeySet
|
|
| ClusterId
|
|
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
|
|
|
instance Universe ClusterSettingsKey
|
|
instance Finite ClusterSettingsKey
|
|
|
|
nullaryPathPiece ''ClusterSettingsKey (camelToPathPiece' 1)
|
|
|
|
deriveJSON
|
|
defaultOptions
|
|
{ constructorTagModifier = camelToPathPiece' 1
|
|
}
|
|
''ClusterSettingsKey
|
|
|
|
instance ToJSONKey ClusterSettingsKey where
|
|
toJSONKey = toJSONKeyText $ \v -> let String t = toJSON v in t
|
|
|
|
instance FromJSONKey ClusterSettingsKey where
|
|
fromJSONKey = FromJSONKeyTextParser $ parseJSON . String
|
|
|
|
instance PersistField ClusterSettingsKey where
|
|
toPersistValue = PersistText . toPathPiece
|
|
fromPersistValue (PersistText t) = maybe (Left $ "Could not parse " <> t) Right $ fromPathPiece t
|
|
fromPersistValue _other = Left "Expecting PersistText"
|
|
|
|
instance PersistFieldSql ClusterSettingsKey where
|
|
sqlType _ = SqlString
|
|
|
|
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 'ClusterClientSessionKey where
|
|
type ClusterSettingValue 'ClusterClientSessionKey = ClientSession.Key
|
|
initClusterSetting _ = liftIO $ view _2 <$> ClientSession.randomKey
|
|
knownClusterSetting _ = ClusterClientSessionKey
|
|
|
|
instance ToJSON ClientSession.Key where
|
|
toJSON = Aeson.String . decodeUtf8 . Base64.encode . Serialize.encode
|
|
|
|
instance FromJSON ClientSession.Key where
|
|
parseJSON = Aeson.withText "Key" $ \t -> do
|
|
bytes <- either fail return . Base64.decode $ encodeUtf8 t
|
|
either fail return $ Serialize.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
|