{- This file is part of Vervis.
 -
 - Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

-- | In this module I'd like to collect all the operation access checks. When a
-- given user asks to perform a certain operation, do we accept the request and
-- perform the changes to our database etc.? The functions here should provide
-- the answer.
--
-- Vervis uses a role-based access control system (RBAC) with role inheritance.
-- In order to determine access to a given operation, conceptually the
-- following two steps happen:
--
--     (1) Determine the actor's role
--     (2) Determine whether that role has access to the operation
--
-- There are 3 mechanisms for assigning a role to actors:
--
--     (1) Local:
--         A given project or repo may keep a list of users on the same server.
--         to which they are assigning roles.
--     (2) Capability:
--         For users from other instances, we provide signed capability
--         documents when they get assigned a role, and we verify them when the
--         user requests to perform an operation. We keep a token for each
--         capability we grant, so that we can revoke it, and so that we can
--         have a list of remote project/repo members.
--     (3) Public:
--         If an actor doesn't have a role through one of the previous two
--         methods, we may still assign a role to them using automatic
--         assignment. It's called _Public_ because it's generally meant for
--         assigning to the general public, people who aren't listed in our
--         role assignment lists, and to give public access to resources. A
--         project or repo may define a role to be assigned automatically
--         depending on the status of the actor. For example, assign a certain
--         role if it's a local logged-in user, or if it's an anonymous
--         not-logged-in client POSTing some operation, or if it's a remote
--         user from another instance, verified with a valid signature approved
--         by their server.
--
-- Conceptually, the default if none of these methods assign a role, is to
-- assume a "null role" i.e. a hypothetical role that can't access any
-- operations.
module Vervis.Access
    ( ObjectAccessStatus (..)
    , checkRepoAccess'
    , checkRepoAccess
    , checkProjectAccess

    , GrantResourceBy (..)
    , unhashGrantResourcePure
    , unhashGrantResource
    , unhashGrantResourceE
    , unhashGrantResource'
    , unhashGrantResourceE'
    , unhashGrantResource404
    , hashGrantResource
    , getGrantResource
    , getGrantResource404

    , grantResourceLocalActor

    , verifyCapability
    )
where

import Control.Applicative ((<|>))
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Barbie
import Data.Bifunctor
import Data.Maybe
import Data.Text (Text)
import Database.Persist
import Database.Persist.Sql
import GHC.Generics
import Yesod.Core.Handler

import qualified Database.Esqueleto as E

import Control.Concurrent.Actor
import Web.Actor.Persist (stageHashidsContext)
import Yesod.Hashids
import Yesod.MonadSite

import Control.Monad.Trans.Except.Local
import Data.Either.Local
import Database.Persist.Local

import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Role
import Vervis.Persist.Actor
import Vervis.Query
import Vervis.Recipient

data ObjectAccessStatus =
    NoSuchObject | ObjectAccessDenied | ObjectAccessAllowed
        deriving Eq

data PersonRole = Developer | User | Guest | RoleID RoleId

{-
data RepoAuthorization
    = RepoAuthorizationLocal PersonId
    | RepoAuthorizationRemote RepoRemoteCollabId

data ProjectAuthorization
    = ProjectAuthorizationLocal PersonId
    | ProjectAuthorizationRemote ProjectRemoteCollabId
-}

roleHasAccess
    :: MonadIO m
    => PersonRole
    -> ProjectOperation
    -> ReaderT SqlBackend m Bool
roleHasAccess Developer     _  = pure True
roleHasAccess User          op = pure $ userAccess op
    where
    userAccess ProjOpOpenTicket      = True
    userAccess ProjOpAcceptTicket    = False
    userAccess ProjOpCloseTicket     = False
    userAccess ProjOpReopenTicket    = False
    userAccess ProjOpRequestTicket   = True
    userAccess ProjOpClaimTicket     = False
    userAccess ProjOpUnclaimTicket   = True
    userAccess ProjOpAssignTicket    = False
    userAccess ProjOpUnassignTicket  = False
    userAccess ProjOpAddTicketDep    = False
    userAccess ProjOpRemoveTicketDep = False
    userAccess ProjOpPush            = False
    userAccess ProjOpApplyPatch      = False
roleHasAccess Guest         _  = pure False
roleHasAccess (RoleID rlid) op =
    fmap isJust . runMaybeT $
        MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op)
    where
    roleHas role operation = getBy $ UniqueRoleAccess role operation
    ancestorHas = flip getProjectRoleAncestorWithOpQ

status :: Bool -> ObjectAccessStatus
status True  = ObjectAccessAllowed
status False = ObjectAccessDenied

checkRepoAccess'
    :: MonadIO m
    => Maybe PersonId
    -> ProjectOperation
    -> RepoId
    -> ReaderT SqlBackend m ObjectAccessStatus
checkRepoAccess' mpid op repoID = do
    mer <- runMaybeT $ do
        repo <- MaybeT $ get repoID
        return $ Entity repoID repo
    case mer of
        Nothing -> return NoSuchObject
        Just (Entity rid repo) -> do
            role <- do
                case mpid of
                    Just pid ->
                        fromMaybe User . (<|> asUser repo) <$> asCollab rid pid
                    Nothing -> pure $ fromMaybe Guest $ asAnon repo
            status <$> roleHasAccess role op
    where
    asCollab rid pid = do
        fmap (const Developer) . listToMaybe <$> do
            E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do
                E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab
                E.on $ topic E.^. CollabTopicRepoCollab E.==. recip E.^. CollabRecipLocalCollab
                E.where_ $
                    topic E.^. CollabTopicRepoRepo E.==. E.val rid E.&&.
                    recip E.^. CollabRecipLocalPerson E.==. E.val pid
                E.limit 1
                return $ topic E.^. CollabTopicRepoCollab
    asUser = fmap RoleID . repoCollabUser
    asAnon = fmap RoleID . repoCollabAnon

checkRepoAccess
    :: (MonadIO m, MonadSite m, YesodHashids (SiteEnv m))
    => Maybe PersonId
    -> ProjectOperation
    -> KeyHashid Repo
    -> ReaderT SqlBackend m ObjectAccessStatus
checkRepoAccess mpid op repoHash = do
    mer <- runMaybeT $ do
        repoID <- decodeKeyHashidM repoHash
        repo <- MaybeT $ get repoID
        return $ Entity repoID repo
    case mer of
        Nothing -> return NoSuchObject
        Just (Entity rid repo) -> do
            role <- do
                case mpid of
                    Just pid ->
                        fromMaybe User . (<|> asUser repo) <$> asCollab rid pid
                    Nothing -> pure $ fromMaybe Guest $ asAnon repo
            status <$> roleHasAccess role op
    where
    asCollab rid pid = do
        fmap (const Developer) . listToMaybe <$> do
            E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do
                E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab
                E.on $ topic E.^. CollabTopicRepoCollab E.==. recip E.^. CollabRecipLocalCollab
                E.where_ $
                    topic E.^. CollabTopicRepoRepo E.==. E.val rid E.&&.
                    recip E.^. CollabRecipLocalPerson E.==. E.val pid
                E.limit 1
                return $ topic E.^. CollabTopicRepoCollab
    asUser = fmap RoleID . repoCollabUser
    asAnon = fmap RoleID . repoCollabAnon

checkProjectAccess
    :: (MonadIO m, MonadSite m, YesodHashids (SiteEnv m))
    => Maybe PersonId
    -> ProjectOperation
    -> KeyHashid Deck
    -> ReaderT SqlBackend m ObjectAccessStatus
checkProjectAccess mpid op deckHash = do
    mej <- runMaybeT $ do
        deckID <- decodeKeyHashidM deckHash
        deck <- MaybeT $ get deckID
        return $ Entity deckID deck
    case mej of
        Nothing -> return NoSuchObject
        Just (Entity jid project) -> do
            role <- do
                case mpid of
                    Just pid ->
                        fromMaybe User . (<|> asUser project) <$>
                            asCollab jid pid
                    Nothing -> pure $ fromMaybe Guest $ asAnon project
            status <$> roleHasAccess role op
    where
    asCollab jid pid = do
        fmap (const Developer) . listToMaybe <$> do
            E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do
                E.on $ topic E.^. CollabTopicDeckCollab E.==. enable E.^. CollabEnableCollab
                E.on $ topic E.^. CollabTopicDeckCollab E.==. recip E.^. CollabRecipLocalCollab
                E.where_ $
                    topic E.^. CollabTopicDeckDeck E.==. E.val jid E.&&.
                    recip E.^. CollabRecipLocalPerson E.==. E.val pid
                E.limit 1
                return $ topic E.^. CollabTopicDeckCollab
    asUser = fmap RoleID . deckCollabUser
    asAnon = fmap RoleID . deckCollabAnon

data GrantResourceBy f
    = GrantResourceRepo (f Repo)
    | GrantResourceDeck (f Deck)
    | GrantResourceLoom (f Loom)
    deriving (Generic, FunctorB, TraversableB, ConstraintsB)

deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f)

unhashGrantResourcePure ctx = f
    where
    f (GrantResourceRepo r) =
        GrantResourceRepo <$> decodeKeyHashidPure ctx r
    f (GrantResourceDeck d) =
        GrantResourceDeck <$> decodeKeyHashidPure ctx d
    f (GrantResourceLoom l) =
        GrantResourceLoom <$> decodeKeyHashidPure ctx l

unhashGrantResource resource = do
    ctx <- asksSite siteHashidsContext
    return $ unhashGrantResourcePure ctx resource

unhashGrantResourceE resource e =
    ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource

unhashGrantResource' resource = do
    ctx <- asksEnv stageHashidsContext
    return $ unhashGrantResourcePure ctx resource

unhashGrantResourceE' resource e =
    ExceptT $ maybe (Left e) Right <$> unhashGrantResource' resource

unhashGrantResource404 = maybe notFound return <=< unhashGrantResource

hashGrantResource (GrantResourceRepo k) =
    GrantResourceRepo <$> encodeKeyHashid k
hashGrantResource (GrantResourceDeck k) =
    GrantResourceDeck <$> encodeKeyHashid k
hashGrantResource (GrantResourceLoom k) =
    GrantResourceLoom <$> encodeKeyHashid k

getGrantResource (GrantResourceRepo k) e =
    GrantResourceRepo <$> getEntityE k e
getGrantResource (GrantResourceDeck k) e =
    GrantResourceDeck <$> getEntityE k e
getGrantResource (GrantResourceLoom k) e =
    GrantResourceLoom <$> getEntityE k e

getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
    where
    getGrantResourceEntity (GrantResourceRepo k) =
        fmap GrantResourceRepo <$> getEntity k
    getGrantResourceEntity (GrantResourceDeck k) =
        fmap GrantResourceDeck <$> getEntity k
    getGrantResourceEntity (GrantResourceLoom k) =
        fmap GrantResourceLoom <$> getEntity k

grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l

verifyCapability
    :: MonadIO m
    => (LocalActorBy Key, OutboxItemId)
    -> Either PersonId RemoteActorId
    -> GrantResourceBy Key
    -> ExceptT Text (ReaderT SqlBackend m) ()
verifyCapability (capActor, capItem) actor resource = do

    -- Find the activity itself by URI in the DB
    nameExceptT "Capability activity not found" $
        verifyLocalActivityExistsInDB capActor capItem

    -- Find the Collab record for that activity
    collabID <- do
        maybeEnable <- lift $ getValBy $ UniqueCollabEnableGrant capItem
        collabEnableCollab <$>
            fromMaybeE maybeEnable "No CollabEnable for this activity"

    -- Find the recipient of that Collab
    recipID <-
        lift $ bimap collabRecipLocalPerson collabRecipRemoteActor <$>
            requireEitherAlt
                (getValBy $ UniqueCollabRecipLocal collabID)
                (getValBy $ UniqueCollabRecipRemote collabID)
                "No collab recip"
                "Both local and remote recips for collab"

    -- Verify the recipient is the expected one
    unless (recipID == actor) $
        throwE "Collab recipient is someone else"

    -- Find the local topic, on which this Collab gives access
    topic <- lift $ do
        maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
        maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
        maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
        case (maybeRepo, maybeDeck, maybeLoom) of
            (Nothing, Nothing, Nothing) -> error "Collab without topic"
            (Just r, Nothing, Nothing) ->
                return $ GrantResourceRepo $ collabTopicRepoRepo r
            (Nothing, Just d, Nothing) ->
                return $ GrantResourceDeck $ collabTopicDeckDeck d
            (Nothing, Nothing, Just l) ->
                return $ GrantResourceLoom $ collabTopicLoomLoom l
            _ -> error "Collab with multiple topics"

    -- Verify that topic is indeed the sender of the Grant
    unless (grantResourceLocalActor topic == capActor) $
        error "Grant sender isn't the topic"

    -- Verify the topic matches the resource specified
    unless (topic == resource) $
        throwE "Capability topic is some other local resource"

    -- Since there are currently no roles, and grants allow only the "Admin"
    -- role that supports every operation, we don't need to check role access
    return ()