switch from parsec to megaparsec. Add REBAC cli tools.

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

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,29 +68,29 @@ pRole =
     string "Administrator" *> pure Administrator
 
 pUserId :: Parser UserId
-pUserId = UserId <$> (read <$> many1 digit)
+pUserId = UserId <$> (read <$> some digitChar)
 
 pUserCmd :: Parser UserCmd
 pUserCmd =
        do string "list"
           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)
 

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    <relation-tuple> <comment> - add a new relation tuple"
+  , "rebac remove-relation <relation-tuple> <comment> - 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
+       }

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"

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

shell.nix

@@ -1,7 +1,7 @@
 with (import <nixpkgs> {}).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";