-- The basic notions to define access control.

-- Hierarchical categories to classify persons, roles, etc.
data Category = Administrative | Accounting | Sales
 deriving (Eq,Show)

-- The objects having access to the system (persons, programs).
data Principal = Alice | Bob | Carol
 deriving (Eq,Show)

-- The action to be performed on resources.
data Action = Edit | View
 deriving (Eq,Show)

-- The resources of the system.
data Resource = PasswdFile | SalesDB | AccountingDB
 deriving (Eq,Show)

-- Results of authorization requests.
data Authorization = Grant | Deny
 deriving (Eq,Show)

-- An example authorization policy:

-- The categories contained in a given category:
subCats :: Category -> [Category]
subCats Administrative = [Accounting, Sales]
subCats Accounting     = []
subCats Sales          = []

-- The categories associated to a principal:
roles :: Principal -> [Category]
roles Alice = [Administrative]
roles Bob   = [Sales]
roles Carol = [Accounting]

-- The permissions given for a category:
permits :: Category -> [(Action,Resource)]
permits Administrative = [(Edit, PasswdFile), (View, PasswdFile)]
permits Accounting     = [(Edit, AccountingDB), (View, SalesDB)]
permits Sales          = [(Edit, SalesDB), (View, AccountingDB)]

------------------------------------------------------------------------
-- Operation to compute authorizations for a given principal, action,
-- and resource. The authorization is granted if the principal
-- has (directly or indirectly) a role with permits the required access.

auth :: Principal -> Action -> Resource -> Authorization
auth p a r | (a, r) `elem` concatMap permits (allCats (roles p)) = Grant
           | otherwise                                           = Deny
 where
  -- Transitive closure of categories w.r.t. subcategory relation.
  allCats :: [Category] -> [Category]
  allCats (c : cs) = c : allCats (subCats c ++ cs)
  allCats []       = []

------------------------------------------------------------------------
-- Functional logic programming allows non-trivial queries:
--
-- Query: what is Alice allowed to Edit?
-- > solve $ auth Alice Edit x == Grant where x free
-- {x=PasswdFile} True
-- {x=SalesDB} True
-- {x=AccountingDB} True
--
-- Query: who can edit the SalesDB resource?
-- > solve $ auth x Edit SalesDB == Grant where x free
-- {x=Alice} True
-- {x=Bob} True

------------------------------------------------------------------------
-- Now we evolve the initial set of policies:

subCats' :: Category -> [Category]
subCats' Administrative = [Sales]
subCats' Accounting     = []
subCats' Sales          = []

-- In order to compute the differences resulting from the new policy,
-- we parameterize the authorization operation over policy specifications:

gauth :: (Category -> [(Action,Resource)])
      -> (Principal -> [Category])
      -> (Category -> [Category])
      -> Principal -> Action -> Resource -> Authorization
gauth car pc cc p a r | (a, r) `elem` concatMap car (allCats (pc p)) = Grant
                      | otherwise                                    = Deny
 where
  allCats (c : cs) = c : allCats (cc c ++ cs)
  allCats []       = []

-- ... and compute the differential for regression testing:
diffAuths :: Principal -> Action -> Resource
          -> Authorization -> Authorization -> Bool
diffAuths p a r auth1 auth2
  | gauth permits roles subCats  p a r == auth1 &&
    gauth permits roles subCats' p a r == auth2 &&
    auth1 /= auth2 = True

-- Compare the changes between the two policies:
-- > diffAuths p a r authold authnew   where p,a,r,authold,authnew free
-- {p=Alice, a=Edit, r=AccountingDB, authold=Grant, authnew=Deny} True
-- {p=Alice, a=View, r=SalesDB, authold=Grant, authnew=Deny} True