{-# language CPP #-}
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')

#if MIN_VERSION_network(3,0,0)
import Network.Socket (SockAddr(..))
import Data.Acid.Remote (openRemoteStateSockAddr, skipAuthenticationPerform)
#else
import Network (PortID(UnixSocket))
import Data.Acid.Remote (openRemoteState, skipAuthenticationPerform)
#endif
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 (UserCmd -> UserCmd -> Bool
(UserCmd -> UserCmd -> Bool)
-> (UserCmd -> UserCmd -> Bool) -> Eq UserCmd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserCmd -> UserCmd -> Bool
$c/= :: UserCmd -> UserCmd -> Bool
== :: UserCmd -> UserCmd -> Bool
$c== :: UserCmd -> UserCmd -> Bool
Eq, Eq UserCmd
Eq UserCmd
-> (UserCmd -> UserCmd -> Ordering)
-> (UserCmd -> UserCmd -> Bool)
-> (UserCmd -> UserCmd -> Bool)
-> (UserCmd -> UserCmd -> Bool)
-> (UserCmd -> UserCmd -> Bool)
-> (UserCmd -> UserCmd -> UserCmd)
-> (UserCmd -> UserCmd -> UserCmd)
-> Ord UserCmd
UserCmd -> UserCmd -> Bool
UserCmd -> UserCmd -> Ordering
UserCmd -> UserCmd -> UserCmd
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UserCmd -> UserCmd -> UserCmd
$cmin :: UserCmd -> UserCmd -> UserCmd
max :: UserCmd -> UserCmd -> UserCmd
$cmax :: UserCmd -> UserCmd -> UserCmd
>= :: UserCmd -> UserCmd -> Bool
$c>= :: UserCmd -> UserCmd -> Bool
> :: UserCmd -> UserCmd -> Bool
$c> :: UserCmd -> UserCmd -> Bool
<= :: UserCmd -> UserCmd -> Bool
$c<= :: UserCmd -> UserCmd -> Bool
< :: UserCmd -> UserCmd -> Bool
$c< :: UserCmd -> UserCmd -> Bool
compare :: UserCmd -> UserCmd -> Ordering
$ccompare :: UserCmd -> UserCmd -> Ordering
$cp1Ord :: Eq UserCmd
Ord, ReadPrec [UserCmd]
ReadPrec UserCmd
Int -> ReadS UserCmd
ReadS [UserCmd]
(Int -> ReadS UserCmd)
-> ReadS [UserCmd]
-> ReadPrec UserCmd
-> ReadPrec [UserCmd]
-> Read UserCmd
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [UserCmd]
$creadListPrec :: ReadPrec [UserCmd]
readPrec :: ReadPrec UserCmd
$creadPrec :: ReadPrec UserCmd
readList :: ReadS [UserCmd]
$creadList :: ReadS [UserCmd]
readsPrec :: Int -> ReadS UserCmd
$creadsPrec :: Int -> ReadS UserCmd
Read, Int -> UserCmd -> ShowS
[UserCmd] -> ShowS
UserCmd -> String
(Int -> UserCmd -> ShowS)
-> (UserCmd -> String) -> ([UserCmd] -> ShowS) -> Show UserCmd
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserCmd] -> ShowS
$cshowList :: [UserCmd] -> ShowS
show :: UserCmd -> String
$cshow :: UserCmd -> String
showsPrec :: Int -> UserCmd -> ShowS
$cshowsPrec :: Int -> UserCmd -> ShowS
Show)

showUserHelp :: [String]
showUserHelp :: [String]
showUserHelp =
    [ String
"user list                          - show all users"
    , String
"user show <userid>                 - show profile data for <userid>"
    , String
"user add-role <userid> <role>      - add a role (such as Administrator)"
    , String
"user remove-role <userid> <role>   - remove a role"
    ]

pRole :: Parser Role
pRole :: Parser Role
pRole =
    String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"Administrator" ParsecT String () Identity String -> Parser Role -> Parser Role
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Role -> Parser Role
forall (f :: * -> *) a. Applicative f => a -> f a
pure Role
Administrator

pUserId :: Parser UserId
pUserId :: Parser UserId
pUserId = Integer -> UserId
UserId (Integer -> UserId)
-> ParsecT String () Identity Integer -> Parser UserId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Integer
forall a. Read a => String -> a
read (String -> Integer)
-> ParsecT String () Identity String
-> ParsecT String () Identity Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit)

pUserCmd :: Parser UserCmd
pUserCmd :: Parser UserCmd
pUserCmd =
{-
       do string "list"
          return UCList
       <|>
-}
       do String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"show"
          ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
          UserId
u <- Parser UserId
pUserId
          UserCmd -> Parser UserCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (UserId -> UserCmd
UCShow UserId
u)
       Parser UserCmd -> Parser UserCmd -> Parser UserCmd
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
       do String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"add-role"
          ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
          UserId
u <- Parser UserId
pUserId
          ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
          Role
r <- Parser Role
pRole
          UserCmd -> Parser UserCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (UserId -> Role -> UserCmd
UCAddRole UserId
u Role
r)
       Parser UserCmd -> Parser UserCmd -> Parser UserCmd
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
       do String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"remove-role"
          ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
          UserId
u <- Parser UserId
pUserId
          ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
          Role
r <- Parser Role
pRole
          UserCmd -> Parser UserCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (UserId -> Role -> UserCmd
UCRemoveRole UserId
u Role
r)

execUserCommand :: UserCmd -> ReaderT (AcidState ProfileDataState) IO ()
{-
execUserCommand UCList =
    do a <- ask
       all <- query' a GetUserIdUsernames
       lift $ print all
       return ()
-}
execUserCommand :: UserCmd -> ReaderT (AcidState ProfileDataState) IO ()
execUserCommand (UCShow UserId
uid) =
    do AcidState ProfileDataState
a <- ReaderT
  (AcidState ProfileDataState) IO (AcidState ProfileDataState)
forall r (m :: * -> *). MonadReader r m => m r
ask
       ProfileData
pd <- AcidState (EventState GetProfileData)
-> GetProfileData
-> ReaderT
     (AcidState ProfileDataState) IO (EventResult GetProfileData)
forall event (m :: * -> *).
(QueryEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
query' AcidState (EventState GetProfileData)
AcidState ProfileDataState
a (UserId -> GetProfileData
GetProfileData UserId
uid)
       IO () -> ReaderT (AcidState ProfileDataState) IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ReaderT (AcidState ProfileDataState) IO ())
-> IO () -> ReaderT (AcidState ProfileDataState) IO ()
forall a b. (a -> b) -> a -> b
$ ProfileData -> IO ()
forall a. Show a => a -> IO ()
print ProfileData
pd
execUserCommand (UCAddRole UserId
uid Role
role) =
    do AcidState ProfileDataState
a <- ReaderT
  (AcidState ProfileDataState) IO (AcidState ProfileDataState)
forall r (m :: * -> *). MonadReader r m => m r
ask
       AcidState (EventState AddRole)
-> AddRole
-> ReaderT (AcidState ProfileDataState) IO (EventResult AddRole)
forall event (m :: * -> *).
(UpdateEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
update' AcidState (EventState AddRole)
AcidState ProfileDataState
a (UserId -> Role -> AddRole
AddRole UserId
uid Role
role)
execUserCommand (UCRemoveRole UserId
uid Role
role) =
    do AcidState ProfileDataState
a <- ReaderT
  (AcidState ProfileDataState) IO (AcidState ProfileDataState)
forall r (m :: * -> *). MonadReader r m => m r
ask
       AcidState (EventState RemoveRole)
-> RemoveRole
-> ReaderT (AcidState ProfileDataState) IO (EventResult RemoveRole)
forall event (m :: * -> *).
(UpdateEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
update' AcidState (EventState RemoveRole)
AcidState ProfileDataState
a (UserId -> Role -> RemoveRole
RemoveRole UserId
uid Role
role)

initUserCommand :: FilePath -> IO (UserCmd -> IO ())
initUserCommand :: String -> IO (UserCmd -> IO ())
initUserCommand String
basePath =
#if MIN_VERSION_network(3,0,0)
  do AcidState ProfileDataState
profileData <- (CommChannel -> IO ())
-> SockAddr -> IO (AcidState ProfileDataState)
forall st.
IsAcidic st =>
(CommChannel -> IO ()) -> SockAddr -> IO (AcidState st)
openRemoteStateSockAddr CommChannel -> IO ()
skipAuthenticationPerform (String -> SockAddr
SockAddrUnix ((String
basePath String -> ShowS
</> String
"profileData_socket")))
#else
  do profileData <- openRemoteState skipAuthenticationPerform "localhost" (UnixSocket ((basePath </> "profileData_socket")))
#endif
     (UserCmd -> IO ()) -> IO (UserCmd -> IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((UserCmd -> IO ()) -> IO (UserCmd -> IO ()))
-> (UserCmd -> IO ()) -> IO (UserCmd -> IO ())
forall a b. (a -> b) -> a -> b
$ \UserCmd
c -> ReaderT (AcidState ProfileDataState) IO ()
-> AcidState ProfileDataState -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (UserCmd -> ReaderT (AcidState ProfileDataState) IO ()
execUserCommand UserCmd
c) AcidState ProfileDataState
profileData

userCLIHandler :: FilePath -> IO CLIHandler
userCLIHandler :: String -> IO CLIHandler
userCLIHandler String
basePath =
  do UserCmd -> IO ()
exec <- String -> IO (UserCmd -> IO ())
initUserCommand String
basePath
     CLIHandler -> IO CLIHandler
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CLIHandler -> IO CLIHandler) -> CLIHandler -> IO CLIHandler
forall a b. (a -> b) -> a -> b
$ CLIHandler :: forall cmd.
String -> (cmd -> IO ()) -> Parser cmd -> [String] -> CLIHandler
CLIHandler
       { cliPrefix :: String
cliPrefix = String
"user"
       , cliExec :: UserCmd -> IO ()
cliExec   = UserCmd -> IO ()
exec
       , cliParser :: Parser UserCmd
cliParser = Parser UserCmd
pUserCmd
       , cliHelp :: [String]
cliHelp   = [String]
showUserHelp
       }