{-# LANGUAGE OverloadedStrings #-}

module ChuSQL.Server.Privileges (
    Grant (..),
    Membership (..),
    PrivilegeCommand (..),
    PrivilegeError (..),
    Privileges,
    RoleView (..),
    authorize,
    authorizeTables,
    filterTables,
    listRoleViews,
    newPrivileges,
    normalizeObject,
    privilegeCommand,
    runPrivilegeCommand,
) where

import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalName)
import ChuSQL.Interface.Protocol (Grant (..), RoleView (..))
import ChuSQL.Server.Backend (
    Backend (..),
    exprTables,
    systemDatabaseName,
    tableRefsOf,
 )
import ChuSQL.Server.Catalog (
    Catalog,
    addGrant,
    addMember,
    dropRole,
    eachAction,
    insertRole,
    newCatalog,
    normalizeObject,
    normalizeRole,
    normalizeUser,
    readGrants,
    readMembers,
    readRoleNames,
    removeGrant,
    removeMember,
    withCatalogLock,
    ensureCatalog,
 )
import Data.List (nub, sort)
import Data.Text (Text)
import qualified Data.Text as T

-- 角色与权限服务：角色、授权与成员关系落在 system 库的表里，并据此判权限。

-- | 出错口径与账号服务一致
data PrivilegeError = PrivilegeError Text Text
    deriving (Show, Eq)

-- 一条角色授权（定义在共享协议层）
-- | 角色成员资格
data Membership = Membership
    { memberRole :: Text
    , memberUser :: Text
    }
    deriving (Show, Eq, Ord)

-- | 一个角色的全貌：授权与成员

data PrivilegeCommand
    = CreateRoleCommand Text
    | DropRoleCommand Text
    | GrantPrivilegesCommand [Text] Text Text
    | RevokePrivilegesCommand [Text] Text Text
    | GrantRoleCommand Text [Text]
    | RevokeRoleCommand Text [Text]
    deriving (Show, Eq)

data Privileges = Privileges
    { pvCatalog :: Catalog
    }

-- | 建权限服务，固定在 system 库上
newPrivileges :: Backend -> IO Privileges
newPrivileges base = Privileges <$> newCatalog (beWithDatabase base systemDatabaseName)

-- | 语句转管理命令，不认的给 Nothing
privilegeCommand :: Statement -> Maybe PrivilegeCommand
privilegeCommand stmt = case stmt of
    CreateRole name -> Just (CreateRoleCommand (T.pack name))
    DropRole name -> Just (DropRoleCommand (T.pack name))
    GrantPrivileges privs obj role ->
        Just (GrantPrivilegesCommand (map T.toLower (map T.pack privs)) (T.pack obj) (T.pack role))
    RevokePrivileges privs obj role ->
        Just (RevokePrivilegesCommand (map T.toLower (map T.pack privs)) (T.pack obj) (T.pack role))
    GrantRole role members -> Just (GrantRoleCommand (T.pack role) (map T.pack members))
    RevokeRole role members -> Just (RevokeRoleCommand (T.pack role) (map T.pack members))
    _ -> Nothing

-- | 执行管理命令：只有管理员能跑，命令提到的角色必须已经存在
runPrivilegeCommand :: Privileges -> Principal -> Text -> PrivilegeCommand -> IO (Either PrivilegeError ())
runPrivilegeCommand service principal database command
    | not (principalIsRoot principal) = pure (Left forbidden)
    | needsDatabase = pure (Left (PrivilegeError "no_database" "no database selected"))
    | otherwise = withTables service (applyCommand service database command)
  where
    -- | 授权到具体对象时需要先选库
    needsDatabase = T.null database && case command of
        GrantPrivilegesCommand _ object _ -> T.strip object /= "*"
        RevokePrivilegesCommand _ object _ -> T.strip object /= "*"
        _ -> False

-- | 语句鉴权：管理员全通，普通身份按需查
authorize :: Privileges -> Principal -> Text -> Statement -> IO (Either PrivilegeError ())
authorize service principal database stmt
    | principalIsRoot principal = pure (Right ())
    | otherwise = case requiredActions stmt of
        Nothing -> pure (Left forbidden)
        Just needed -> authorizeTables service principal database needed

-- | 直接查一组 (表, 权限)：一键接口用这个
authorizeTables :: Privileges -> Principal -> Text -> [(Text, Text)] -> IO (Either PrivilegeError ())
authorizeTables service principal database needed
    | principalIsRoot principal = pure (Right ())
    | otherwise = withTables service $ do
        grants <- grantsOfUser service (principalName principal)
        pure (grants >>= \found -> checkAll database found needed)

-- | 只留下用户有 SELECT 权的表
filterTables :: Privileges -> Principal -> Text -> [Text] -> IO (Either PrivilegeError [Text])
filterTables service principal database tables
    | principalIsRoot principal = pure (Right tables)
    | otherwise = withTables service $ do
        grants <- grantsOfUser service (principalName principal)
        pure ((\found -> [table | table <- tables, checkAll database found [(table, "select")] == Right ()]) <$> grants)

-- | 角色总览（REST 与测试用）
listRoleViews :: Privileges -> IO (Either PrivilegeError [RoleView])
listRoleViews service = withTables service $ do
    names <- roleNames service
    case names of
        Left err -> pure (Left err)
        Right known -> sequence <$> mapM view (sort known)
  where
    -- | 组装一个角色的总览
    view role = do
        grants <- roleGrantsOf service role
        members <- membersOfRole service role
        pure (RoleView role <$> grants <*> members)

-- | 一条语句需要哪些 (表, 权限)
requiredActions :: Statement -> Maybe [(Text, Text)]
requiredActions stmt = case stmt of
    Select{} -> Just (selectNeeds (selectFrom stmt) (maybe [] (: []) (selectWhere stmt)))
    SelectExpr{} ->
        Just (selectNeeds (selectFrom stmt) (maybe [] (: []) (selectWhere stmt) ++ map snd (selectItems stmt)))
    Insert table _ rows -> Just ((T.pack table, "insert") : selectsOf (concat rows))
    Update table assigns cond -> Just ((T.pack table, "update") : selectsOf (map snd assigns ++ maybe [] (: []) cond))
    Delete table cond -> Just ((T.pack table, "delete") : selectsOf (maybe [] (: []) cond))
    _ -> Nothing
  where
    -- | FROM 子句要的 SELECT 权限
    selectNeeds source exprs = [(ref, "select") | ref <- nub (tableRefsOf source)] ++ selectsOf exprs
    -- | 表达式里子查询要的 SELECT 权限
    selectsOf exprs = [(ref, "select") | ref <- nub (concatMap exprTables exprs)]

-- | 每项 (表, 权限) 都要被某条授权覆盖
checkAll :: Text -> [Grant] -> [(Text, Text)] -> Either PrivilegeError ()
checkAll database grants needed = case [pair | pair@(table, privilege) <- needed, not (covered table privilege)] of
    [] -> Right ()
    ((table, privilege) : _) ->
        Left (PrivilegeError "forbidden" ("permission denied: " <> T.toUpper privilege <> " ON " <> table))
  where
    -- | 某一项是否被授权覆盖
    covered table privilege =
        let target = normalizeObject database table
         in any
                (\grant -> (grantObject grant == "*" || grantObject grant == target) && grantPrivilege grant == privilege)
                grants

-- | 一个用户实际能用的授权：所属角色加上继承来的
grantsOfUser :: Privileges -> Text -> IO (Either PrivilegeError [Grant])
grantsOfUser service user = do
    members <- catalog (readMembers (pvCatalog service))
    grants <- catalog (readGrants (pvCatalog service))
    roles <- roleNames service
    pure $ do
        memberRows <- members
        grantRows <- grants
        known <- roles
        let edges = roleEdges memberRows known
            mine = closureUp edges [role | (role, member) <- memberRows, member == normalizeUser user]
        pure [grant | grant <- grantRows, grantRole grant `elem` mine]

-- | 角色到角色的成员边：父角色在前
roleEdges :: [(Text, Text)] -> [Text] -> [(Text, Text)]
roleEdges members roles = [pair | pair@(_, child) <- members, child `elem` roles]

-- | 向上闭包：这群角色直接或间接所属的全部角色
closureUp :: [(Text, Text)] -> [Text] -> [Text]
closureUp edges = go
  where
    -- | 展开一轮，没有再新增就停
    go known =
        let more = [parent | (parent, child) <- edges, child `elem` known, parent `notElem` known]
         in if null more then known else go (known ++ more)

-- | 一个角色挂着的授权
roleGrantsOf :: Privileges -> Text -> IO (Either PrivilegeError [Grant])
roleGrantsOf service role = do
    grants <- catalog (readGrants (pvCatalog service))
    pure (filter (\grant -> grantRole grant == normalizeRole role) <$> grants)

-- | 角色名清单（统一小写）
roleNames :: Privileges -> IO (Either PrivilegeError [Text])
roleNames service = catalog (readRoleNames (pvCatalog service))

-- | 一个角色的直接成员：用户与子角色
membersOfRole :: Privileges -> Text -> IO (Either PrivilegeError [Text])
membersOfRole service role = do
    members <- catalog (readMembers (pvCatalog service))
    pure (map snd . filter (\(name, _) -> name == normalizeRole role) <$> members)

-- | 角色必须存在，否则命令不落地
requireRole :: Privileges -> Text -> IO (Either PrivilegeError ())
requireRole service role = do
    known <- roleNames service
    pure $ case known of
        Left err -> Left err
        Right names
            | normalizeRole role `elem` names -> Right ()
            | otherwise -> Left (unknownRole role)

-- | 真正落库（表已经保证存在）
applyCommand :: Privileges -> Text -> PrivilegeCommand -> IO (Either PrivilegeError ())
applyCommand service database command = case command of
    CreateRoleCommand role -> do
        known <- roleNames service
        case known of
            Left err -> pure (Left err)
            Right names
                | normalizeRole role `elem` names -> pure (Left (PrivilegeError "conflict" ("role already exists: " <> role)))
                | otherwise -> catalog (insertRole (pvCatalog service) role)
    DropRoleCommand role -> do
        allowed <- requireRole service role
        case allowed of
            Left err -> pure (Left err)
            Right () -> catalog (dropRole (pvCatalog service) role)
    GrantPrivilegesCommand privileges object role -> do
        allowed <- requireRole service role
        case allowed of
            Left err -> pure (Left err)
            Right () ->
                eachAction (expandPrivileges privileges) $ \privilege ->
                    catalog (addGrant (pvCatalog service) role privilege (normalizeObject database object))
    RevokePrivilegesCommand privileges object role -> do
        allowed <- requireRole service role
        case allowed of
            Left err -> pure (Left err)
            Right () ->
                eachAction (expandPrivileges privileges) $ \privilege ->
                    catalog (removeGrant (pvCatalog service) role privilege (normalizeObject database object))
    GrantRoleCommand role members -> do
        allowed <- requireRole service role
        case allowed of
            Left err -> pure (Left err)
            Right () -> do
                known <- roleNames service
                case known of
                    Left err -> pure (Left err)
                    Right roles -> eachAction members (grantMember service roles role)
    RevokeRoleCommand role users -> do
        allowed <- requireRole service role
        case allowed of
            Left err -> pure (Left err)
            Right () -> eachAction users $ \user -> catalog (removeMember (pvCatalog service) role user)

-- | 加一条成员边：名字是角色就查环，否则当用户加
grantMember :: Privileges -> [Text] -> Text -> Text -> IO (Either PrivilegeError ())
grantMember service roles role member = do
    current <- membersOfRole service role
    case current of
        Left err -> pure (Left err)
        Right known
            | normalizeUser member `elem` known -> pure (Right ())
            | normalizeRole member `notElem` roles -> catalog (addMember (pvCatalog service) role member)
            | otherwise -> do
                edges <- membershipEdges service
                case edges of
                    Left err -> pure (Left err)
                    Right pairs
                        | normalizeRole member `elem` closureUp pairs [normalizeRole role] ->
                            pure (Left (cycleMember role member))
                        | otherwise -> catalog (addMember (pvCatalog service) role member)

-- | 只保留两端都是角色的成员边
membershipEdges :: Privileges -> IO (Either PrivilegeError [(Text, Text)])
membershipEdges service = do
    members <- catalog (readMembers (pvCatalog service))
    roles <- roleNames service
    pure (roleEdges <$> members <*> roles)

-- | 全程持锁，先保证系统表存在再跑动作
withTables :: Privileges -> IO (Either PrivilegeError a) -> IO (Either PrivilegeError a)
withTables service action = withCatalogLock (pvCatalog service) $ do
    ready <- ensureCatalog (pvCatalog service)
    case ready of
        Left err -> pure (Left (storageError err))
        Right () -> action

-- | 目录操作转成权限错误
catalog :: IO (Either String a) -> IO (Either PrivilegeError a)
catalog action = fmap (either (Left . storageError) Right) action

-- | 把 ALL 展开成四种具体权限
expandPrivileges :: [Text] -> [Text]
expandPrivileges privileges = nub (concatMap expand (map (T.toLower . T.strip) privileges))
  where
    -- | 展开一条权限名
    expand "all" = ["select", "insert", "update", "delete"]
    expand other = [other]

forbidden :: PrivilegeError
forbidden = PrivilegeError "forbidden" "administrator required"

-- | 未知角色的错误
unknownRole :: Text -> PrivilegeError
unknownRole role = PrivilegeError "not_found" ("unknown role: " <> role)

-- | 角色成员成环的错误
cycleMember :: Text -> Text -> PrivilegeError
cycleMember role member =
    PrivilegeError "conflict" ("role membership would create a cycle: " <> normalizeRole role <> " and " <> normalizeRole member)

-- | 存储错误转成权限错误
storageError :: String -> PrivilegeError
storageError message = PrivilegeError "storage_error" ("privilege storage: " <> T.pack message)