-- The information required for an access control policy:

-- The principals of our system:
data Principal = Alice | Bob | Carol
 deriving (Eq, Show)

-- The categories (or roles) in our system:
data Category = Administrative | Accounting | Sales
 deriving (Eq, Show)

-- Our resources:
data Resource = PasswdFile | SalesDB | AccountingDB
 deriving (Eq, Show)

-- Possible actions on the resource:
data Action = Edit | View
 deriving (Eq, Show)

-- Result of an access control:
data Authorization = Grant | Deny
 deriving (Eq, Show)


-- The roles of the principals:
roles :: Principal -> [Category]
roles Alice = [Administrative]
roles Bob   = [Sales]
roles Carol = [Accounting]

-- Hierarchy of the categories:
subCats :: Category -> [Category]
subCats Administrative = [Accounting, Sales]
subCats Accounting     = []
subCats Sales          = []

-- What are the permissions of a category?
permits :: Category -> [(Action,Resource)]
permits Administrative = [(Edit,PasswdFile),   (View, PasswdFile)]
permits Accounting     = [(Edit,AccountingDB), (View,SalesDB)]
permits Sales          = [(Edit,SalesDB),      (View, AccountingDB)]


-- Check the authorization: which are the rights of a principal
-- to perform an action on a resource?
auth :: Principal -> Action -> Resource -> Authorization
auth p a r | (a,r) `elem` concatMap permits (allCats (roles p)) = Grant
           | otherwise                                          = Deny
 where
  allCats []     = []
  allCats (c:cs) = c : allCats (subCats c ++ cs)


-- Query: which resources can be edited by Alice?
-- > solve $ auth Alice Edit x == Grant where x free

-- Query: who can edit the sales database?
-- > solve $ auth p Edit SalesDB == Grant where p free

--------------------------------------------------------------------
-- Check consequences of access control policy rule changes?

-- New hierarchy of the categories:
subCats' :: Category -> [Category]
subCats' Administrative = [Sales]
subCats' Accounting     = []
subCats' Sales          = []

-- Check the authorization: which are the rights of a principal
-- to perform an action on a resource?
auth' :: Principal -> Action -> Resource -> Authorization
auth' p a r | (a,r) `elem` concatMap permits (allCats (roles p)) = Grant
            | otherwise                                          = Deny
 where
  allCats []     = []
  allCats (c:cs) = c : allCats (subCats' c ++ cs)

-- Compute all consequences of the policy changes:

-- First step: parameterize `auth` on the policies:

-- Check the authorization: which are the rights of a principal
-- to perform an action on a resource w.r.t. policies as parameters?
authP :: (Category -> [(Action,Resource)])
      -> (Principal -> [Category])
      -> (Category -> [Category])
      -> Principal -> Action -> Resource -> Authorization
authP car pc subcats p a r
  | (a,r) `elem` concatMap car (allCats (pc p)) = Grant
  | otherwise                                   = Deny
 where
  allCats []     = []
  allCats (c:cs) = c : allCats (subcats c ++ cs)

-- Now:
-- auth = authP permits roles subCats
-- auth' = authP permits roles subCats'

-- Compute the consequences of different policies:
diffAuths :: Principal -> Action -> Resource -> (Authorization, Authorization)
diffAuths p a r
  | authP permits roles subCats  p a r == auth1 &&
    authP permits roles subCats' p a r == auth2 &&
    auth1 /= auth2
  = (auth1, auth2)
 where
  auth1, auth2 free


-- Compute all consequences of our policy changes:
-- > diffAuths p a r where p,a,r free
-- {p=Alice, a=Edit, r=AccountingDB} (Grant,Deny)
-- {p=Alice, a=View, r=SalesDB} (Grant,Deny)