Compare commits
3 Commits
b435a57d7b
...
ef8c9acd32
Author | SHA1 | Date |
---|---|---|
Saku Laesvuori | ef8c9acd32 | |
Saku Laesvuori | 777c635c0c | |
Saku Laesvuori | fb7c8f7cf3 |
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
; ""))
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
Loading…
Reference in New Issue