{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}

module Datarekisteri.Backend.DB where

import Data.ByteString (ByteString)
import Data.Text (Text)
import Database.Persist.TH (persistUpperCase, mkPersist, sqlSettings)
import Database.Persist (Entity, Key, entityKey, PersistEntity)
import Database.Persist.Sql (fromSqlKey, toSqlKey)
import Database.Persist.Postgresql.JSON (Value)
import Datarekisteri.Core.Types
import Datarekisteri.Backend.Types

mkPersist sqlSettings [persistUpperCase|
DBUser sql=users
  registered Time
  passwordCrypt PasswordHash
  permissions Text
  accepted (Maybe Time)
  memberData Value sqltype=jsonb

  deriving (Show)

DBEmail sql=emails
  uid DBUserId
  email Email sqltype=varchar(320)
  vid (Maybe DBEmailVerificationId) sql=verification

  UniqueUserVerified uid vid
  -- This enables using persistent functions to get unique verified emails. The real
  -- constraint is stricter and doesn't allow having more than one null and one non-null
  -- verification but it's too complicated for persistent to understand.

  UniqueEmail email
  UniqueVerification vid

DBEmailVerification sql=emailVerifications
  secret Text sqltype=varchar(255)
  expires Time

  UniqueVerificationSecret secret

DBKey sql=keys
  uid DBUserId
  data ByteString
  expires (Maybe Time)
  uploaded Time
  comment Text
  isPrimaryEncryptionKey Bool

DBToken sql=tokens
  uid DBUserId
  name (Maybe Text)
  data Text
  comment Text
  issued Time
  expires (Maybe Time)
  permissions Text

  UniqueNameUid name uid
  UniqueData data
|]

entityToID :: FromDBKey a => Entity (DB a) -> a
entityToID = fromDBKey . entityKey

class PersistEntity (DB a) =>  FromDBKey a where
    type DB a
    fromDBKey :: Key (DB a) -> a

instance FromDBKey UserID where
    type DB UserID = DBUser
    fromDBKey = UserID . fromIntegral . fromSqlKey

instance FromDBKey TokenID where
    type DB TokenID = DBToken
    fromDBKey = TokenID . fromIntegral . fromSqlKey

instance FromDBKey KeyID where
    type DB KeyID = DBKey
    fromDBKey = KeyID . fromIntegral . fromSqlKey

class FromDBKey a => ToDBKey a where
    toDBKey :: a -> Key (DB a)

instance ToDBKey UserID where
    toDBKey (UserID x) = toSqlKey $ fromIntegral x

instance ToDBKey KeyID where
    toDBKey (KeyID x) = toSqlKey $ fromIntegral x

instance ToDBKey TokenID where
    toDBKey (TokenID x) = toSqlKey $ fromIntegral x