Skip to content

Commit

Permalink
add some useful debug commands to rebac CLI
Browse files Browse the repository at this point in the history
  • Loading branch information
@stepcut
stepcut committed Nov 5, 2024
1 parent f9e1256 commit 44d9196
Show file tree
Hide file tree
Showing 2 changed files with 143 additions and 18 deletions.
150 changes: 136 additions & 14 deletions Clckwrks/CLI/Rebac.hs
View file
Original file line number Diff line number Diff line change
@@ -1,16 +1,25 @@
{-# language OverloadedStrings #-}
{-# language DataKinds, OverloadedStrings #-}
module Clckwrks.CLI.Rebac where

import AccessControl.Relation (RelationTuple(..), pRelationTuple, ppRelationTuple, ppRelationTuples)
import AccessControl.Check (RelPerm, check, lookupSubjects, lookupSubjectsWithType, mkDefMap)
import AccessControl.Relation ( Relation, RelationTuple(..), Object(..), ObjectType(..), ObjectWildcard(..)
, hasRelation, hasResource, hasResourceType, hasSubject, hasSubjectType
, pObject, pObjectType, pObjectWild, pRelation, pRelationTuple
, ppRelationTuple, ppRelationTuples
)
import AccessControl.Schema (Schema(definitions), Permission(..), parseSchema, pPermission)
import Control.Applicative ((<$>), (<*>), (*>), pure)
import Clckwrks (UserId(..))
import Clckwrks.CLI.Core (CLIHandler(..), Parser)
import Clckwrks.Rebac.Acid (AddRelationTuple(..), RebacState, GetRelationTuples(..), GetRelationLog(..), RLEAction(..), RelationLogEntry(..), RemoveRelationTuple(..))
import Control.Monad.Reader
import Data.Acid (AcidState)
import Data.Acid.Advanced (query', update')
import qualified Data.ByteString as BS
import Data.Map (Map)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time.Clock (getCurrentTime)
import Network.Socket (SockAddr(..))
import Data.Acid.Remote (openRemoteStateSockAddr, skipAuthenticationPerform)
Expand All @@ -29,6 +38,15 @@ data RebacCmd
| RCRelationTuples
| RCAddRelationTuple RelationTuple Text
| RCRemoveRelationTuple RelationTuple Text
| RCCheck (Object NoWildcard) Permission (Object NoWildcard) -- ^ resource, permission, subject
| RCHasSubjectType ObjectType
| RCHasSubject (Object AllowWildcard)
| RCHasResourceType ObjectType
| RCHasResource (Object NoWildcard)
| RCHasRelation Relation
| RCHasResourceTypeRelation ObjectType Relation
| RCHasResourceRelation (Object NoWildcard) Relation
| RCHasResourceTypeSubject ObjectType (Object AllowWildcard)
deriving (Eq, Ord, Read, Show)

showRebacHelp :: [ String ]
Expand All @@ -37,6 +55,15 @@ showRebacHelp =
, "rebac relations - show all currently active relation tuples"
, "rebac add-relation <relation-tuple> <comment> - add a new relation tuple"
, "rebac remove-relation <relation-tuple> <comment> - remove a relation tuple"
, "rebac check <resourceType:resourceId> <permission> <subjectType:subjectId> - check if a subject has permission on resource"
, "rebac has-subject-type <subjectType> - show all relations with the specified subject type"
, "rebac has-subject <subjectType:subjectId> - show all relation tuples with the specified subject"
, "rebac has-resource-type <resourceType> - show all relation tuples with the specified resource type"
, "rebac has-resource <resourceType:resourceId> - show all relation tuples with the specified resource"
, "rebac has-relation <relation> - show all relation tuples with the specified relation"
, "rebac has-resource-type-relation <resourceType> <relation> - show all subjects for the specific resource type & relation"
, "rebac has-resource-relation <resourceType:resourceId> <relation> - show all subjects for the specific resource & relation"
, "rebac has-resource-type-subject <resourceType> <subjectType:subjectId> - show all tuples for the specific resource type & subject"
]

pComment :: Parser Text
Expand All @@ -58,6 +85,55 @@ pRebacCmd =
rt <- pRelationTuple
comment <- pComment
pure (RCRemoveRelationTuple rt comment)
, do string "check"
hspace
resource <- pObject
hspace
perm <- pPermission
hspace
subject <- pObject
pure (RCCheck resource perm subject)
, do string "has-subject-type"
hspace
st <- pObjectType
pure (RCHasSubjectType st)
, do string "has-subject"
hspace
sbj <- pObjectWild
pure (RCHasSubject sbj)
, try $
do string "has-resource-type"
hspace
rt <- pObjectType
pure (RCHasResourceType rt)
, try $
do string "has-resource-type-subject"
hspace
rt <- pObjectType
hspace
subject <- pObjectWild
pure (RCHasResourceTypeSubject rt subject)
, try $
do string "has-resource"
hspace
res <- pObject
pure (RCHasResource res)
, do try $ string "has-resource-type-relation"
hspace
resTy <- pObjectType
hspace
rel <- pRelation
pure (RCHasResourceTypeRelation resTy rel)
, do string "has-resource-relation"
hspace
res <- pObject
hspace
rel <- pRelation
pure (RCHasResourceRelation res rel)
, do string "has-relation"
hspace
rel <- pRelation
pure (RCHasRelation rel)
]

ppRelationLogEntry (RelationLogEntry timestamp relationTuple action comment) =
Expand All @@ -69,35 +145,81 @@ ppRelationLogEntry (RelationLogEntry timestamp relationTuple action comment) =
ppRelationLogEntries :: [ RelationLogEntry ] -> Doc
ppRelationLogEntries entries = PP.vcat $ map ppRelationLogEntry entries

execRebacCommand :: RebacCmd -> ReaderT (AcidState RebacState) IO ()
execRebacCommand RCRelationLog =
execRebacCommand :: RebacCmd -> Maybe (Map T.Text RelPerm) -> ReaderT (AcidState RebacState) IO ()
execRebacCommand RCRelationLog _ =
do a <- ask
rl <- query' a GetRelationLog
liftIO $ print $ ppRelationLogEntries rl
execRebacCommand RCRelationTuples =
execRebacCommand RCRelationTuples _ =
do a <- ask
rt <- query' a GetRelationTuples
liftIO $ print $ ppRelationTuples rt
execRebacCommand (RCAddRelationTuple rt comment) =
execRebacCommand (RCAddRelationTuple rt comment) _ =
do a <- ask
now <- liftIO getCurrentTime
e <- update' a (AddRelationTuple rt now comment)
liftIO $ print $ ppRelationLogEntry e
execRebacCommand (RCRemoveRelationTuple rt comment) =
execRebacCommand (RCRemoveRelationTuple rt comment) _ =
do a <- ask
now <- liftIO getCurrentTime
e <- update' a (RemoveRelationTuple rt now comment)
liftIO $ print $ ppRelationLogEntry e
execRebacCommand (RCCheck resource perm subject) Nothing =
do liftIO $ print "No schema file was specified -- unable to do anything"
execRebacCommand (RCCheck resource perm subject) (Just rsDefMap) =
do a <- ask
rts <- query' a GetRelationTuples
let access = check rsDefMap rts resource perm subject
liftIO $ print access
execRebacCommand (RCHasSubjectType st) _ =
do a <- ask
rt <- query' a GetRelationTuples
liftIO $ print $ ppRelationTuples $ filter (hasSubjectType st) rt
execRebacCommand (RCHasSubject sbj) _ =
do a <- ask
rt <- query' a GetRelationTuples
liftIO $ print $ ppRelationTuples $ filter (hasSubject sbj) rt
execRebacCommand (RCHasResourceType resTy) _ =
do a <- ask
rt <- query' a GetRelationTuples
liftIO $ print $ ppRelationTuples $ filter (hasResourceType resTy) rt
execRebacCommand (RCHasResourceTypeSubject resTy subject) _ =
do a <- ask
rts <- query' a GetRelationTuples
liftIO $ print $ ppRelationTuples $ filter (\rt -> hasResourceType resTy rt && hasSubject subject rt) rts
execRebacCommand (RCHasResource res) _ =
do a <- ask
rt <- query' a GetRelationTuples
liftIO $ print $ ppRelationTuples $ filter (hasResource res) rt
execRebacCommand (RCHasRelation rel) _ =
do a <- ask
rt <- query' a GetRelationTuples
liftIO $ print $ ppRelationTuples $ filter (hasRelation rel) rt
execRebacCommand (RCHasResourceRelation res rel) _ =
do a <- ask
rts <- query' a GetRelationTuples
liftIO $ print $ ppRelationTuples $ filter (\rt -> hasRelation rel rt && hasResource res rt) rts
execRebacCommand (RCHasResourceTypeRelation resTy rel) _ =
do a <- ask
rts <- query' a GetRelationTuples
liftIO $ print $ ppRelationTuples $ filter (\rt -> hasRelation rel rt && hasResourceType resTy rt) rts


initRebacCommand :: FilePath -> IO (RebacCmd -> IO ())
initRebacCommand basePath =
initRebacCommand :: FilePath -> Maybe FilePath -> IO (RebacCmd -> IO ())
initRebacCommand basePath mSchemaPath =
do rebac <- openRemoteStateSockAddr skipAuthenticationPerform (SockAddrUnix ((basePath </> "rebac_socket")))
pure $ \c -> runReaderT (execRebacCommand c) rebac
mRsDefMap <-
case mSchemaPath of
Nothing -> pure Nothing
(Just schemaPath) ->
do c <- BS.readFile schemaPath
pure $ case parseSchema $ T.decodeUtf8 $ c of
(Left e) -> error e
(Right s) -> Just $ mkDefMap (definitions s)
pure $ \c -> runReaderT (execRebacCommand c mRsDefMap) rebac

rebacCLIHandler :: FilePath -> IO CLIHandler
rebacCLIHandler basePath =
do exec <- initRebacCommand basePath
rebacCLIHandler :: FilePath -> Maybe FilePath -> IO CLIHandler
rebacCLIHandler basePath mSchema =
do exec <- initRebacCommand basePath mSchema
pure $ CLIHandler
{ cliPrefix = "rebac"
, cliExec = exec
Expand Down
11 changes: 7 additions & 4 deletions Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,9 +10,12 @@ main :: IO ()
main =
do args <- getArgs
case args of
[basePath] ->
do u <- userCLIHandler basePath
r <- rebacCLIHandler basePath
(basePath:rest) ->
do let mSchemaPath = case rest of
[] -> Nothing
[pth] -> Just pth
u <- userCLIHandler basePath
r <- rebacCLIHandler basePath mSchemaPath
loop [u, r]
putStrLn "type 'help' for a list of commands."
_ -> putStrLn "Usage: clckwrks-cli path/to/_state"
_ -> putStrLn "Usage: clckwrks-cli path/to/_state [path to rebac schema]"

0 comments on commit 44d9196

Please sign in to comment.