From f9e1256b81d7a575c2012b4f467305e2c2419e07 Mon Sep 17 00:00:00 2001 From: Jeremy Shaw Date: Fri, 1 Nov 2024 11:14:09 -0500 Subject: [PATCH] switch from parsec to megaparsec. Add REBAC cli tools. --- Clckwrks/CLI/Core.hs | 14 +++-- Clckwrks/CLI/ProfileData.hs | 21 +++---- Clckwrks/CLI/Rebac.hs | 106 ++++++++++++++++++++++++++++++++++++ Main.hs | 4 +- clckwrks-cli.cabal | 14 +++-- shell.nix | 4 +- 6 files changed, 142 insertions(+), 21 deletions(-) create mode 100644 Clckwrks/CLI/Rebac.hs diff --git a/Clckwrks/CLI/Core.hs b/Clckwrks/CLI/Core.hs index 73a0e07..234f581 100644 --- a/Clckwrks/CLI/Core.hs +++ b/Clckwrks/CLI/Core.hs @@ -1,4 +1,4 @@ -{-# language ExistentialQuantification #-} +{-# language ExistentialQuantification, OverloadedStrings #-} module Clckwrks.CLI.Core where import Control.Applicative ((<$>), (<*>), (*>), pure) @@ -10,11 +10,17 @@ import Data.Acid.Advanced (query', update') import Data.Acid.Remote (openRemoteState, skipAuthenticationPerform) import Data.Map (Map) import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as T +import Data.Void (Void) import System.Environment import System.Exit (exitSuccess) import System.Console.Haskeline -import Text.Parsec -import Text.Parsec.String +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +type Parser = Parsec Void Text data CLIHandler = forall cmd. CLIHandler { cliPrefix :: String @@ -58,7 +64,7 @@ loop handlers' = _ -> case Map.lookup prefix handlers of Nothing -> liftIO $ putStrLn $ "unknow command prefix: " ++ prefix (Just (CLIHandler _ exec parser _)) -> - do let r = parse parser input rest + do let r = parse parser input (T.pack rest) case r of (Left e) -> do liftIO $ print e diff --git a/Clckwrks/CLI/ProfileData.hs b/Clckwrks/CLI/ProfileData.hs index 6edf836..b6ffd62 100644 --- a/Clckwrks/CLI/ProfileData.hs +++ b/Clckwrks/CLI/ProfileData.hs @@ -1,9 +1,9 @@ -{-# language CPP #-} +{-# language CPP, OverloadedStrings #-} module Clckwrks.CLI.ProfileData where import Control.Applicative ((<$>), (<*>), (*>), pure) import Clckwrks (UserId(..)) -import Clckwrks.CLI.Core (CLIHandler(..)) +import Clckwrks.CLI.Core (CLIHandler(..), Parser) import Clckwrks.ProfileData.Acid (ProfileDataState(..), GetProfileData(..), GetUserIdDisplayNames(..), AddRole(..), RemoveRole(..)) import Clckwrks.ProfileData.Types (Role(..)) import Control.Monad.Reader @@ -20,8 +20,9 @@ import Data.Acid.Remote (openRemoteState, skipAuthenticationPerform) import System.Environment import System.FilePath (()) import System.Console.Haskeline -import Text.Parsec -import Text.Parsec.String +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L -- right now this just connects to the server and makes UserId 1 an administrator -- @@ -67,7 +68,7 @@ pRole = string "Administrator" *> pure Administrator pUserId :: Parser UserId -pUserId = UserId <$> (read <$> many1 digit) +pUserId = UserId <$> (read <$> some digitChar) pUserCmd :: Parser UserCmd pUserCmd = @@ -75,21 +76,21 @@ pUserCmd = return UCList <|> do string "show" - skipMany1 space + skipSome space u <- pUserId return (UCShow u) <|> do string "add-role" - skipMany1 space + skipSome space u <- pUserId - skipMany1 space + skipSome space r <- pRole return (UCAddRole u r) <|> do string "remove-role" - skipMany1 space + skipSome space u <- pUserId - skipMany1 space + skipSome space r <- pRole return (UCRemoveRole u r) diff --git a/Clckwrks/CLI/Rebac.hs b/Clckwrks/CLI/Rebac.hs new file mode 100644 index 0000000..f757831 --- /dev/null +++ b/Clckwrks/CLI/Rebac.hs @@ -0,0 +1,106 @@ +{-# language OverloadedStrings #-} +module Clckwrks.CLI.Rebac where + +import AccessControl.Relation (RelationTuple(..), pRelationTuple, ppRelationTuple, ppRelationTuples) +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 Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (getCurrentTime) +import Network.Socket (SockAddr(..)) +import Data.Acid.Remote (openRemoteStateSockAddr, skipAuthenticationPerform) +import qualified Data.Text as T +import System.Environment +import System.FilePath (()) +import System.Console.Haskeline +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L +import Text.PrettyPrint.HughesPJ (Doc, (<+>), ($$), ($+$)) +import qualified Text.PrettyPrint.HughesPJ as PP + +data RebacCmd + = RCRelationLog + | RCRelationTuples + | RCAddRelationTuple RelationTuple Text + | RCRemoveRelationTuple RelationTuple Text + deriving (Eq, Ord, Read, Show) + +showRebacHelp :: [ String ] +showRebacHelp = + [ "rebac relation-log - show entire relation log (will eventually get very long)" + , "rebac relations - show all currently active relation tuples" + , "rebac add-relation - add a new relation tuple" + , "rebac remove-relation - remove a relation tuple" + ] + +pComment :: Parser Text +pComment = T.pack <$> (hspace *> some printChar) + +pRebacCmd :: Parser RebacCmd +pRebacCmd = + msum [ do string "relation-log" + pure RCRelationLog + , do string "relations" + pure RCRelationTuples + , do string "add-relation" + hspace + rt <- pRelationTuple + comment <- pComment + pure (RCAddRelationTuple rt comment) + , do string "remove-relation" + hspace + rt <- pRelationTuple + comment <- pComment + pure (RCRemoveRelationTuple rt comment) + ] + +ppRelationLogEntry (RelationLogEntry timestamp relationTuple action comment) = + PP.text (show timestamp) <+> ppAction action <+> ppRelationTuple relationTuple <+> PP.text (T.unpack comment) + where + ppAction RLEAdd = PP.text "+" + ppAction RLERemove = PP.text "-" + +ppRelationLogEntries :: [ RelationLogEntry ] -> Doc +ppRelationLogEntries entries = PP.vcat $ map ppRelationLogEntry entries + +execRebacCommand :: RebacCmd -> ReaderT (AcidState RebacState) IO () +execRebacCommand RCRelationLog = + do a <- ask + rl <- query' a GetRelationLog + liftIO $ print $ ppRelationLogEntries rl +execRebacCommand RCRelationTuples = + do a <- ask + rt <- query' a GetRelationTuples + liftIO $ print $ ppRelationTuples rt +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) = + do a <- ask + now <- liftIO getCurrentTime + e <- update' a (RemoveRelationTuple rt now comment) + liftIO $ print $ ppRelationLogEntry e + + +initRebacCommand :: FilePath -> IO (RebacCmd -> IO ()) +initRebacCommand basePath = + do rebac <- openRemoteStateSockAddr skipAuthenticationPerform (SockAddrUnix ((basePath "rebac_socket"))) + pure $ \c -> runReaderT (execRebacCommand c) rebac + +rebacCLIHandler :: FilePath -> IO CLIHandler +rebacCLIHandler basePath = + do exec <- initRebacCommand basePath + pure $ CLIHandler + { cliPrefix = "rebac" + , cliExec = exec + , cliParser = pRebacCmd + , cliHelp = showRebacHelp + } diff --git a/Main.hs b/Main.hs index 3777e4d..65728ae 100644 --- a/Main.hs +++ b/Main.hs @@ -2,6 +2,7 @@ module Main where import Clckwrks.CLI.Core import Clckwrks.CLI.ProfileData +import Clckwrks.CLI.Rebac (rebacCLIHandler) import System.FilePath (()) import System.Environment (getArgs) @@ -11,6 +12,7 @@ main = case args of [basePath] -> do u <- userCLIHandler basePath - loop [u] + r <- rebacCLIHandler basePath + loop [u, r] putStrLn "type 'help' for a list of commands." _ -> putStrLn "Usage: clckwrks-cli path/to/_state" diff --git a/clckwrks-cli.cabal b/clckwrks-cli.cabal index 7978d75..bd1f432 100644 --- a/clckwrks-cli.cabal +++ b/clckwrks-cli.cabal @@ -24,13 +24,16 @@ Library Build-depends: acid-state >= 0.12 && < 0.17, base < 5, - clckwrks >= 0.23 && < 0.30, + clckwrks >= 0.23 && < 0.31, containers >= 0.5 && < 0.7, haskeline >= 0.7 && < 0.9, filepath >= 1.4 && < 1.5, mtl >= 2.0 && < 2.3, network >= 2.3 && < 3.2, - parsec == 3.1.* + megaparsec, + pretty, + rebac, + text Executable clckwrks-cli Main-is: @@ -41,11 +44,14 @@ Executable clckwrks-cli Build-depends: acid-state >= 0.12 && < 0.17, base < 5, - clckwrks >= 0.23 && < 0.30, + clckwrks >= 0.23 && < 0.31, clckwrks-cli, containers >= 0.5 && < 0.7, haskeline >= 0.7 && < 0.9, filepath >= 1.4 && < 1.5, mtl >= 2.0 && < 2.3, network >= 2.3 && < 3.2, - parsec == 3.1.* + megaparsec, + pretty, + rebac, + text diff --git a/shell.nix b/shell.nix index a7636e9..467b31f 100644 --- a/shell.nix +++ b/shell.nix @@ -1,7 +1,7 @@ with (import {}).pkgs; let pkg = haskellPackages.callPackage ({ mkDerivation, acid-state, base, clckwrks, haskeline, mtl - , network, parsec, stdenv, cabal-install + , network, megaparsec, stdenv, cabal-install }: mkDerivation { pname = "clckwrks-cli"; @@ -10,7 +10,7 @@ let pkg = haskellPackages.callPackage isLibrary = false; isExecutable = true; buildDepends = [ - acid-state base haskeline mtl network parsec cabal-install clckwrks + acid-state base haskeline mtl network megaparsec cabal-install clckwrks ]; homepage = "http://www.clckwrks.com/"; description = "a command-line interface for adminstrating some aspects of clckwrks";