{-# 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


data ClusterSettingsKey
  = ClusterCryptoIDKey
  | ClusterClientSessionKey
  | ClusterSecretBoxKey
  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