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

@@ -0,0 +1,181 @@
+(define-module (datarekisteri-service)
+  #:use-module (datarekisteri-package)
+  #:use-module (guix gexp)
+  #:use-module (guix records)
+  #:use-module (gnu packages admin)
+  #:use-module (gnu services)
+  #:use-module (gnu services certbot)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu services databases)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu services web)
+  #:use-module (gnu system shadow)
+
+  #:export (plain-datarekisteri-frontend-service-type
+            plain-datarekisteri-frontend-configuration
+
+            plain-datarekisteri-backend-service-type
+            plain-datarekisteri-backend-configuration))
+
+(define-maybe/no-serialization string)
+
+(define-configuration/no-serialization plain-datarekisteri-frontend-configuration
+  (datarekisteri-frontend
+   (file-like datarekisteri-frontend)
+   "The datarekisteri-frontend package to use.")
+  (backend-url
+   (string)
+   "The URL for the datarekisteri backend server.")
+  (port
+   (integer 3000)
+   "The TCP port to listen on.")
+  (root-url
+   (string)
+   "The root URL for this server."))
+
+(define (frontend-shepherd-service config)
+  (match-record config <plain-datarekisteri-frontend-configuration>
+    (backend-url port root-url datarekisteri-frontend)
+    (list (shepherd-service
+           (documentation "Run the datarekisteri frontend HTTP server")
+           (requirement '(networking))
+           (provision '(datarekisteri-frontend))
+           (start
+            #~(make-forkexec-constructor
+               (list #$(file-append datarekisteri-frontend "/bin/datarekisteri-frontend")
+                     "--server-url" #$backend-url
+                     "--port" #$(number->string port)
+                     "--approot" #$root-url)
+               #:user "datarekisteri-frontend"
+               #:group "datarekisteri-frontend"
+               #:directory "/var/lib/datarekisteri-frontend"))
+           (stop #~(make-kill-destructor))))))
+
+(define (frontend-accounts _)
+  (list (user-group
+         (name "datarekisteri-frontend")
+         (system? #t))
+        (user-account
+         (name "datarekisteri-frontend")
+         (system? #t)
+         (group "datarekisteri-frontend")
+         (home-directory "/var/lib/datarekisteri-frontend")
+         (shell (file-append shadow "/bin/nologin")))))
+
+(define plain-datarekisteri-frontend-service-type
+  (service-type
+   (name 'plain-datarekisteri-frontend)
+   (extensions
+     (list (service-extension shepherd-root-service-type frontend-shepherd-service)
+           (service-extension account-service-type frontend-accounts)))
+   (description "Run the datarekisteri HTTP frontend server")))
+
+(define (file-like-or-string? x)
+  (or (file-like? x)
+      (string? x)))
+
+(define-configuration/no-serialization plain-datarekisteri-backend-configuration
+  (datarekisteri-backend
+   (file-like datarekisteri-backend)
+   "The datarekisteri-backend package to use.")
+  (email-address
+   (string)
+   "The email address to send emails from.")
+  (email-sender
+   (maybe-string)
+   "The display name for sending emails.")
+  (port
+   (integer 3100)
+   "The TCP port to listen on.")
+  (sendmail
+   (file-like-or-string)
+   "Path to the sendmail program to send emails with."))
+
+(define (backend-shepherd-service config)
+  (match-record config <plain-datarekisteri-backend-configuration>
+    (email-address email-sender sendmail port datarekisteri-backend)
+    (list (shepherd-service
+           (documentation "Run the datarekisteri backend HTTP server")
+           (requirement '(networking postgres))
+           (provision '(datarekisteri-backend))
+           (start
+            #~(make-forkexec-constructor
+               (list #$(file-append datarekisteri-backend "/bin/datarekisteri-backend")
+                     "--address" #$email-address
+                     #$@(if (maybe-value-set? email-sender) (list "--sender-name" email-sender) '())
+                     "--port" #$(number->string port)
+                     "--sendmail" #$sendmail)
+               #:user "datarekisteri-backend"
+               #:group "datarekisteri-backend"
+               #:directory "/var/lib/datarekisteri-backend"))
+           (stop #~(make-kill-destructor))))))
+
+(define (backend-accounts _)
+  (list (user-group
+         (name "datarekisteri-backend")
+         (system? #t))
+        (user-account
+         (name "datarekisteri-backend")
+         (system? #t)
+         (group "datarekisteri-backend")
+         (home-directory "/var/lib/datarekisteri-backend")
+         (shell (file-append shadow "/bin/nologin")))))
+
+(define (backend-postgresql-roles _)
+  (list (postgresql-role
+          (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")))
+
+; (define datarekisteri-client-service-type
+;   (service-type
+;    (name 'datarekisteri-client)
+;    (extensions
+;      (list (service-extension certbot-service-type client-certbot)
+;            (service-extension nginx-service-type client-nginx)
+;            (service-extension shepherd-root-service-type client-shepherd-service)))
+;    (description "Run the datarekisteri HTTP client server")
+;    (default-value (datarekisteri-client-configuration))))
+
+; (define datarekisteri-api-service-type
+;   (service-type
+;    (name 'datarekisteri-api)
+;    (extensions
+;      (list (service-extension certbot-service-type api-certbot)
+;            (service-extension nginx-service-type api-nginx)
+;            (service-extension postgresql-role-service-type api-postgresql-roles)
+;            (service-extension shepherd-root-service-type api-shepherd-service)))
+;    (description "Run the datarekisteri HTTP api server")
+;    (default-value (datarekisteri-api-configuration))))
+
+; (define-configuration datarekisteri-client-configuration
+;   (https?
+;    (boolean #t)
+;    "Whether to configure HTTPS with certbot.")
+;   (nginx?
+;    (boolean #t)
+;    "Whether to configure nginx as a reverse proxy.")
+;   (api-url
+;    (string)
+;    "The URL for the graphql API server.")
+;   (port
+;    (integer 3000)
+;    "The TCP port to listen on.")
+;   (root-url
+;    (string)
+;    ""))
+

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