{-# LANGUAGE Arrows #-}

module Hasura.RQL.DDL.Schema.Cache.Permission
  ( buildTablePermissions
  , mkPermissionMetadataObject
  ) where

import           Hasura.Prelude

import qualified Data.HashMap.Strict.Extended       as M
import qualified Data.Sequence                      as Seq

import           Control.Arrow.Extended
import           Data.Aeson

import qualified Hasura.Incremental                 as Inc

import           Hasura.Db
import           Hasura.RQL.DDL.Permission
import           Hasura.RQL.DDL.Permission.Internal
import           Hasura.RQL.DDL.Schema.Cache.Common
import           Hasura.RQL.Types
import           Hasura.RQL.Types.Catalog
import           Hasura.SQL.Types

import           Debug.Trace

buildTablePermissions
  :: ( ArrowChoice arr, Inc.ArrowDistribute arr, Inc.ArrowCache arr, ArrowKleisli m arr
     , ArrowWriter (Seq CollectedInfo) arr, MonadTx m, MonadReader BuildReason m )
  => ( TableCoreCache
     , TableCoreInfo
     , HashSet CatalogPermission
     ) `arr` RolePermInfoMap
buildTablePermissions = Inc.cache proc (tableCache, tableInfo, tablePermissions) ->
  (| Inc.keyed (\_ rolePermissions -> do
       let (insertPerms, selectPerms, updatePerms, deletePerms) =
             partitionPermissions rolePermissions

       insertPermInfo <- buildPermission -< (tableCache, tableInfo, insertPerms)
       selectPermInfo <- buildPermission -< (tableCache, tableInfo, selectPerms)
       updatePermInfo <- buildPermission -< (tableCache, tableInfo, updatePerms)
       deletePermInfo <- buildPermission -< (tableCache, tableInfo, deletePerms)

       returnA -< RolePermInfo
         { _permIns = insertPermInfo
         , _permSel = selectPermInfo
         , _permUpd = updatePermInfo
         , _permDel = deletePermInfo
         })
  |) (M.groupOn _cpRole tablePermissions)
  where
    partitionPermissions = flip foldr ([], [], [], []) $
      \perm (insertPerms, selectPerms, updatePerms, deletePerms) -> case _cpPermType perm of
        PTInsert -> (perm:insertPerms, selectPerms, updatePerms, deletePerms)
        PTSelect -> (insertPerms, perm:selectPerms, updatePerms, deletePerms)
        PTUpdate -> (insertPerms, selectPerms, perm:updatePerms, deletePerms)
        PTDelete -> (insertPerms, selectPerms, updatePerms, perm:deletePerms)

mkPermissionMetadataObject :: CatalogPermission -> MetadataObject
mkPermissionMetadataObject (CatalogPermission qt rn pt pDef cmnt) =
  let objectId = MOTableObj qt $ MTOPerm rn pt
      definition = toJSON $ WithTable qt $ PermDef rn pDef cmnt
  in MetadataObject objectId definition

withPermission
  :: (ArrowChoice arr, ArrowWriter (Seq CollectedInfo) arr)
  => WriterA (Seq SchemaDependency) (ErrorA QErr arr) (a, s) b
  -> arr (a, (CatalogPermission, s)) (Maybe b)
withPermission f = proc (e, (permission, s)) -> do
  let CatalogPermission tableName roleName permType _ _ = permission
      metadataObject = mkPermissionMetadataObject permission
      schemaObject = SOTableObj tableName $ TOPerm roleName permType
      addPermContext err = "in permission for role " <> roleName <<> ": " <> err
  (| withRecordInconsistency (
     (| withRecordDependencies (
        (| modifyErrA (f -< (e, s))
        |) (addTableContext tableName . addPermContext))
     |) metadataObject schemaObject)
   |) metadataObject

buildPermission
  :: ( ArrowChoice arr, Inc.ArrowCache arr, ArrowKleisli m arr
     , ArrowWriter (Seq CollectedInfo) arr, MonadTx m, MonadReader BuildReason m
     , Inc.Cacheable a, IsPerm a, FromJSON a, Inc.Cacheable (PermInfo a) )
  => ( TableCoreCache
     , TableCoreInfo
     , [CatalogPermission]
     ) `arr` Maybe (PermInfo a)
buildPermission = Inc.cache proc (tableCache, tableInfo, permissions) -> do
      (permissions >- noDuplicates mkPermissionMetadataObject)
  >-> (| traverseA (\permission@(CatalogPermission _ roleName _ pDef _) ->
         (| withPermission (do
              bindErrorA -< when (roleName == adminRole) $
                throw400 ConstraintViolation "cannot define permission for admin role"
              bindA -< liftTx . liftIO $ traceEventIO "START permissions/build/decode"
              perm <- bindErrorA -< decodeValue pDef
              bindA -< liftTx . liftIO $ traceEventIO "STOP permissions/build/decode"
              let permDef = PermDef roleName perm Nothing
              bindA -< liftTx . liftIO $ traceEventIO "START permissions/build/info"
              (info, dependencies) <- bindErrorA -<
                runTableCoreCacheRT (buildPermInfo tableInfo permDef) tableCache
              bindA -< liftTx . liftIO $ traceEventIO "STOP permissions/build/info"
              tellA -< Seq.fromList dependencies
              rebuildViewsIfNeeded -< (_tciName tableInfo, permDef, info)
              returnA -< info)
         |) permission) |)
  >-> (\info -> join info >- returnA)

rebuildViewsIfNeeded
  :: ( Inc.ArrowCache arr, ArrowKleisli m arr, MonadTx m, MonadReader BuildReason m
     , Inc.Cacheable a, IsPerm a, Inc.Cacheable (PermInfo a) )
  => (QualifiedTable, PermDef a, PermInfo a) `arr` ()
rebuildViewsIfNeeded = Inc.cache $ arrM \(tableName, permDef, info) -> do
  liftTx . liftIO $ traceEventIO "START permissions/build/views"
  buildReason <- ask
  when (buildReason == CatalogUpdate) $
    addPermP2Setup tableName permDef info
  liftTx . liftIO $ traceEventIO "STOP permissions/build/views"