Add CLI for admin operations

.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

.guix/modules/datarekisteri-service.scm

@@ -126,12 +126,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")))
 

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

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