diff --git a/Clckwrks/CLI/Core.hs b/Clckwrks/CLI/Core.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/CLI/Core.hs @@ -0,0 +1,79 @@ +{-# language ExistentialQuantification #-} +module Clckwrks.CLI.Core where + +import Control.Applicative ((<$>), (<*>), (*>), pure) +import Control.Monad (forever) +import Control.Monad.Reader (runReaderT) +import Control.Monad.Trans (liftIO) +import Data.Acid (AcidState) +import Data.Acid.Advanced (query', update') +import Data.Acid.Remote (openRemoteState, skipAuthenticationPerform) +import Data.Map (Map) +import qualified Data.Map as Map +import Network (PortID(UnixSocket)) +import System.Environment +import System.Exit (exitSuccess) +import System.Console.Haskeline +import Text.Parsec +import Text.Parsec.String + +data CLIHandler = forall cmd. CLIHandler + { cliPrefix :: String + , cliExec :: cmd -> IO () + , cliParser :: Parser cmd + , cliHelp :: [String] + } + +data Command + = Quit + | Help + deriving (Eq, Ord, Read, Show) + +pCommand :: Parser Command +pCommand = + do string "quit" *> return Quit + <|> + do string "help" *> return Help + +{- + do string "user" + skipMany1 space + User <$> pUserCmd + <|> +-} + + +loop :: [CLIHandler] -> IO () -- InputT IO () +loop handlers' = + let handlers = Map.fromList (map (\h -> (cliPrefix h, h)) handlers') in + runInputT defaultSettings $ forever $ + do minput <- getInputLine "% " + case minput of + Nothing -> return () + Just input -> + let (prefix, rest') = span (/= ' ') $ dropWhile (== ' ') $ input + rest = dropWhile (== ' ') $ rest' + in case prefix of + "help" -> liftIO $ execCommand (concatMap (cliHelp . snd) (Map.toAscList handlers)) Help + "quit" -> liftIO $ exitSuccess + _ -> case Map.lookup prefix handlers of + Nothing -> liftIO $ putStrLn $ "unknow command prefix: " ++ prefix + (Just (CLIHandler _ exec parser _)) -> + do let r = parse parser input rest + case r of + (Left e) -> + do liftIO $ print e + (Right cmd) -> + do liftIO $ exec cmd + +execCommand :: [String] -> Command -> IO () +execCommand helps Help = + do putStrLn $ unlines $ (helps ++ showHelp) + return () + +showHelp :: [String] +showHelp = + [ "quit - quit" + , "help - show this help" + ] + diff --git a/Clckwrks/CLI/ProfileData.hs b/Clckwrks/CLI/ProfileData.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/CLI/ProfileData.hs @@ -0,0 +1,122 @@ +module Clckwrks.CLI.ProfileData where + +import Control.Applicative ((<$>), (<*>), (*>), pure) +import Clckwrks (UserId(..)) +import Clckwrks.CLI.Core (CLIHandler(..)) +import Clckwrks.ProfileData.Acid (ProfileDataState(..), GetProfileData(..), AddRole(..), RemoveRole(..)) +import Clckwrks.ProfileData.Types (Role(..)) +import Control.Monad.Reader +import Data.Acid (AcidState) +import Data.Acid.Advanced (query', update') +import Data.Acid.Remote (openRemoteState, skipAuthenticationPerform) +import Network (PortID(UnixSocket)) +import System.Environment +import System.FilePath (()) +import System.Console.Haskeline +import Text.Parsec +import Text.Parsec.String + +-- right now this just connects to the server and makes UserId 1 an administrator +-- +-- eventually there should be an actually useful command-line interface +{- +main :: IO () +main = + do [socket] <- getArgs + acid <- openRemoteState "localhost" (UnixSocket socket) + update acid (AddRole (UserId 1) Administrator) + pd <- query acid (GetProfileData (UserId 1)) + print pd +-} +{- +main :: IO () +main = + do args <- getArgs + case args of + [socket] -> + do acid <- openRemoteState skipAuthenticationPerform "localhost" (UnixSocket socket) + putStrLn "type 'help' for a list of commands." + runReaderT (runInputT defaultSettings loop) acid + _ -> putStrLn "Usage: clckwrks-cli path/to/profileData_socket" +-} + +data UserCmd + = UCShow UserId + | UCAddRole UserId Role + | UCRemoveRole UserId Role + deriving (Eq, Ord, Read, Show) + +showUserHelp :: [String] +showUserHelp = + [ "user list - show all users" + , "user show - show profile data for " + , "user add-role - add a role (such as Administrator)" + , "user remove-role - remove a role" + ] + +pRole :: Parser Role +pRole = + string "Administrator" *> pure Administrator + +pUserId :: Parser UserId +pUserId = UserId <$> (read <$> many1 digit) + +pUserCmd :: Parser UserCmd +pUserCmd = +{- + do string "list" + return UCList + <|> +-} + do string "show" + skipMany1 space + u <- pUserId + return (UCShow u) + <|> + do string "add-role" + skipMany1 space + u <- pUserId + skipMany1 space + r <- pRole + return (UCAddRole u r) + <|> + do string "remove-role" + skipMany1 space + u <- pUserId + skipMany1 space + r <- pRole + return (UCRemoveRole u r) + +execUserCommand :: UserCmd -> ReaderT (AcidState ProfileDataState) IO () +{- +execUserCommand UCList = + do a <- ask + all <- query' a GetUserIdUsernames + lift $ print all + return () +-} +execUserCommand (UCShow uid) = + do a <- ask + pd <- query' a (GetProfileData uid) + lift $ print pd +execUserCommand (UCAddRole uid role) = + do a <- ask + update' a (AddRole uid role) +execUserCommand (UCRemoveRole uid role) = + do a <- ask + update' a (RemoveRole uid role) + +initUserCommand :: FilePath -> IO (UserCmd -> IO ()) +initUserCommand basePath = + do profileData <- openRemoteState skipAuthenticationPerform "localhost" (UnixSocket ((basePath "profileData_socket"))) + pure $ \c -> runReaderT (execUserCommand c) profileData + +userCLIHandler :: FilePath -> IO CLIHandler +userCLIHandler basePath = + do exec <- initUserCommand basePath + pure $ CLIHandler + { cliPrefix = "user" + , cliExec = exec + , cliParser = pUserCmd + , cliHelp = showUserHelp + } diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,140 +1,16 @@ module Main where -import Control.Applicative ((<$>), (<*>), (*>), pure) -import Clckwrks (UserId(..)) -import Clckwrks.ProfileData.Acid (ProfileDataState(..), GetProfileData(..), AddRole(..), RemoveRole(..), GetUserIdUsernames(..)) -import Clckwrks.ProfileData.Types (Role(..)) -import Control.Monad.Reader -import Data.Acid (AcidState) -import Data.Acid.Advanced (query', update') -import Data.Acid.Remote (openRemoteState, skipAuthenticationPerform) -import Network (PortID(UnixSocket)) -import System.Environment -import System.Console.Haskeline -import Text.Parsec -import Text.Parsec.String +import Clckwrks.CLI.Core +import Clckwrks.CLI.ProfileData +import System.FilePath (()) +import System.Environment (getArgs) --- right now this just connects to the server and makes UserId 1 an administrator --- --- eventually there should be an actually useful command-line interface -{- main :: IO () main = - do [socket] <- getArgs - acid <- openRemoteState "localhost" (UnixSocket socket) - update acid (AddRole (UserId 1) Administrator) - pd <- query acid (GetProfileData (UserId 1)) - print pd --} -main :: IO () -main = - do args <- getArgs - case args of - [socket] -> - do acid <- openRemoteState skipAuthenticationPerform "localhost" (UnixSocket socket) - putStrLn "type 'help' for a list of commands." - runReaderT (runInputT defaultSettings loop) acid - _ -> putStrLn "Usage: clckwrks-cli path/to/profileData_socket" - -data UserCmd - = UCList - | UCShow UserId - | UCAddRole UserId Role - | UCRemoveRole UserId Role - deriving (Eq, Ord, Read, Show) - -data Command - = User UserCmd - | Quit - | Help - deriving (Eq, Ord, Read, Show) - -showHelp :: String -showHelp = unlines - [ "user list - show all users" - , "user show - show profile data for " - , "user add-role - add a role (such as Administrator)" - , "user remove-role - remove a role" - , "quit - quit" - , "help - show this help" - ] - -pRole :: Parser Role -pRole = - string "Administrator" *> pure Administrator - -pUserId :: Parser UserId -pUserId = UserId <$> (read <$> many1 digit) - -pUserCmd :: Parser UserCmd -pUserCmd = - do string "list" - return UCList - <|> - do string "show" - skipMany1 space - u <- pUserId - return (UCShow u) - <|> - do string "add-role" - skipMany1 space - u <- pUserId - skipMany1 space - r <- pRole - return (UCAddRole u r) - <|> - do string "remove-role" - skipMany1 space - u <- pUserId - skipMany1 space - r <- pRole - return (UCRemoveRole u r) - - -pCommand :: Parser Command -pCommand = - do string "user" - skipMany1 space - User <$> pUserCmd - <|> - do string "quit" *> return Quit - <|> - do string "help" *> return Help - -loop :: InputT (ReaderT (AcidState ProfileDataState) IO) () -loop = do - minput <- getInputLine "% " - case minput of - Nothing -> return () - Just input -> - do let r = parse pCommand input input - case r of - (Left e) -> - do liftIO $ print e - loop - (Right Quit) -> - return () - (Right cmd) -> - do lift $ execCommand cmd - loop - -execCommand :: Command -> ReaderT (AcidState ProfileDataState) IO () -execCommand (User UCList) = - do a <- ask - all <- query' a GetUserIdUsernames - lift $ print all - return () -execCommand (User (UCShow uid)) = - do a <- ask - pd <- query' a (GetProfileData uid) - lift $ print pd -execCommand (User (UCAddRole uid role)) = - do a <- ask - update' a (AddRole uid role) -execCommand (User (UCRemoveRole uid role)) = - do a <- ask - update' a (RemoveRole uid role) -execCommand Help = - do lift $ putStrLn $ showHelp - return () - + do args <- getArgs + case args of + [basePath] -> + do u <- userCLIHandler basePath + loop [u] + 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 --- a/clckwrks-cli.cabal +++ b/clckwrks-cli.cabal @@ -1,5 +1,5 @@ Name: clckwrks-cli -Version: 0.2.17.3 +Version: 0.3.0 Synopsis: a command-line interface for adminstrating some aspects of clckwrks Description: This tool permits browsing of users, changing their roles, and other features. Homepage: http://www.clckwrks.com/ @@ -17,6 +17,21 @@ type: git location: git://github.com/clckwrks/clckwrks-cli.git +Library + default-language: Haskell2010 + Exposed-Modules: Clckwrks.CLI.Core + Clckwrks.CLI.ProfileData + Build-depends: + acid-state >= 0.12 && < 0.16, + base < 5, + clckwrks >= 0.23 && < 0.26, + containers >= 0.6 && < 0.7, + haskeline == 0.7.*, + filepath >= 1.4 && < 1.5, + mtl >= 2.0 && < 2.3, + network >= 2.3 && < 3.2, + parsec == 3.1.* + Executable clckwrks-cli Main-is: Main.hs @@ -24,8 +39,11 @@ Build-depends: acid-state >= 0.12 && < 0.16, base < 5, - clckwrks >= 0.23 && < 0.25, + clckwrks >= 0.23 && < 0.26, + clckwrks-cli >= 0.3 && < 0.4, + containers >= 0.6 && < 0.7, haskeline == 0.7.*, + filepath >= 1.4 && < 1.5, mtl >= 2.0 && < 2.3, - network >= 2.3 && < 2.9, + network >= 2.3 && < 3.2, parsec == 3.1.*