Compare commits

...

3 Commits

4 changed files with 326 additions and 0 deletions

View File

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

View File

@ -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 "--display-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)
; ""))

View File

@ -54,3 +54,37 @@ executable datarekisteri-backend
Paths_datarekisteri_backend Paths_datarekisteri_backend
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 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