diff --git a/.guix/modules/datarekisteri-package.scm b/.guix/modules/datarekisteri-package.scm index 33ca0bb..774c47b 100644 --- a/.guix/modules/datarekisteri-package.scm +++ b/.guix/modules/datarekisteri-package.scm @@ -30,6 +30,7 @@ ghc-base64 ghc-cryptonite ghc-datarekisteri-core + ghc-echo ghc-email-validate ghc-esqueleto ghc-mime-mail diff --git a/.guix/modules/datarekisteri-service.scm b/.guix/modules/datarekisteri-service.scm index 7eec70c..09a5b7b 100644 --- a/.guix/modules/datarekisteri-service.scm +++ b/.guix/modules/datarekisteri-service.scm @@ -126,12 +126,18 @@ (name "datarekisteri-backend") (create-database? #t)))) +(define (backend-profile config) + (match-record config + (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"))) diff --git a/backend/datarekisteri-backend.cabal b/backend/datarekisteri-backend.cabal index 211881d..da23b16 100644 --- a/backend/datarekisteri-backend.cabal +++ b/backend/datarekisteri-backend.cabal @@ -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 diff --git a/backend/src/Datarekisteri/CLI.hs b/backend/src/Datarekisteri/CLI.hs new file mode 100644 index 0000000..3644d4d --- /dev/null +++ b/backend/src/Datarekisteri/CLI.hs @@ -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