Add CLI for admin operations

This commit is contained in:
Saku Laesvuori 2023-09-26 17:46:19 +03:00
parent fb7c8f7cf3
commit 777c635c0c
Signed by: slaesvuo
GPG Key ID: 257D284A2A1D3A32
4 changed files with 151 additions and 0 deletions

View File

@ -30,6 +30,7 @@
ghc-base64
ghc-cryptonite
ghc-datarekisteri-core
ghc-echo
ghc-email-validate
ghc-esqueleto
ghc-mime-mail

View File

@ -122,12 +122,18 @@
(name "datarekisteri-backend")
(create-database? #t))))
(define (backend-profile config)
(match-record config <plain-datarekisteri-backend-configuration>
(datarekisteri-backend)
(list datarekisteri-backend)))
(define plain-datarekisteri-backend-service-type
(service-type
(name 'plain-datarekisteri-backend)
(extensions
(list (service-extension postgresql-role-service-type backend-postgresql-roles)
(service-extension account-service-type backend-accounts)
(service-extension profile-service-type backend-profile)
(service-extension shepherd-root-service-type backend-shepherd-service)))
(description "Run the datarekisteri backend HTTP server")))

View File

@ -54,3 +54,37 @@ executable datarekisteri-backend
Paths_datarekisteri_backend
hs-source-dirs: src
default-language: Haskell2010
executable datarekisteri-cli
build-depends:
aeson,
base,
base64,
containers,
cryptonite,
datarekisteri-core,
echo,
email-validate,
esqueleto,
memory,
mime-mail,
monad-logger,
morpheus-graphql,
morpheus-graphql-app,
morpheus-graphql-core,
morpheus-graphql-server,
mtl,
optparse-applicative,
persistent,
persistent-postgresql,
relude,
text,
time
main-is: Datarekisteri/CLI.hs
other-modules:
Datarekisteri.Backend.DB,
Datarekisteri.Backend.DB.Queries,
Datarekisteri.Backend.Types,
Datarekisteri.Backend.Utils,
hs-source-dirs: src
default-language: Haskell2010

View File

@ -0,0 +1,110 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
import Relude
import "cryptonite" Crypto.Random (MonadRandom(..))
import Control.Monad.Logger (runStderrLoggingT)
import Data.Aeson (toJSON)
import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn)
import Datarekisteri.Backend.DB
import Datarekisteri.Backend.DB.Queries
import Datarekisteri.Backend.Types
import Datarekisteri.Backend.Utils
import Datarekisteri.Core.Types
import Options.Applicative
import System.IO.Echo (withoutInputEcho)
main :: IO ()
main = do
CLIOptions {..} <- execParser $ info (cliOptions <**> helper) mempty
runCLIM optionsDBUrl $ case optionsSubCommand of
AddUser {..} -> do
time <- currentTime
passwordHash <- putStr "Password: " >> liftIO (withoutInputEcho getLine) >>= hashPassword
userID <- addUser $ DBUser
{ dBUserRegistered = time
, dBUserToBeDeleted = Nothing
, dBUserPasswordCrypt = passwordHash
, dBUserPermissions = show addUserPermissions
, dBUserAccepted = Just time
, dBUserSeceded = Nothing
, dBUserRejected = Nothing
, dBUserMemberData = toJSON $ MemberData
{ nickname = addUserNickname
, name = addUserName
, birthdate = addUserBirthdate
, homeplace = addUserHomeplace
, application = addUserApplication
, phoneNumber = addUserPhoneNumber
}
}
_ <- addEmail $ DBEmail
{ dBEmailUid = toDBKey userID
, dBEmailEmail = addUserEmail
, dBEmailVerificationSecret = Nothing
}
pure ()
cliOptions :: Parser CLIOptions
cliOptions = CLIOptions
<$> strOption (short 'u' <> long "db-url" <> metavar "URL" <> value "postgres:///datarekisteri-backend")
<*> cliCommandParser
cliCommandParser :: Parser CLISubCommand
cliCommandParser = hsubparser
$ command "add-user" (info addUserCommand (progDesc "Add a user to datarekisteri"))
addUserCommand :: Parser CLISubCommand
addUserCommand = AddUser
<$> optional (strOption (long "nickname" <> metavar "NAME"))
<*> strOption (long "name" <> metavar "NAME")
<*> option (maybeReader $ toDate . toText) (long "birthdate" <> metavar "DATE" <> help "The user's birthdate, YYYY-MM-DD")
<*> strOption (long "homeplace" <> metavar "NAME" <> help "The user's homeplace, usually a city")
<*> option (maybeReader $ toPhoneNumber . toText) (long "phone-number" <> metavar "PHONE" <> help "The user's phone number. Only numbers, spaces and the plus-sign are allowed")
<*> option (maybeReader $ toEmail . toText) (long "email" <> metavar "EMAIL" <> help "The user's email address.")
<*> (fromList <$> many permissionParser)
<*> strOption (long "application" <> metavar "TEXT" <> value "Added by the admin.")
permissionParser :: Parser (Scope, Permission)
permissionParser = (,)
<$> option auto (long "scope")
<*> option auto (long "permission")
data CLIOptions = CLIOptions
{ optionsDBUrl :: String
, optionsSubCommand :: CLISubCommand
}
data CLISubCommand = AddUser
{ addUserNickname :: Maybe Text
, addUserName :: Text
, addUserBirthdate :: Date
, addUserHomeplace :: Text
, addUserPhoneNumber :: PhoneNumber
, addUserEmail :: Email
, addUserPermissions :: Map Scope Permission
, addUserApplication :: Text
}
newtype CLIM a = CLIM (ReaderT String IO a)
deriving (Functor, Applicative, Monad, MonadIO, MonadReader String)
instance MonadTime CLIM where
currentTime = liftIO currentTime
instance MonadDB CLIM where
runQuery query = do
dbUrl <- ask
liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query
instance MonadRandom CLIM where
getRandomBytes = liftIO . getRandomBytes
runCLIM :: String -> CLIM a -> IO a
runCLIM dbUrl (CLIM m) = runReaderT m dbUrl