Compare commits
3 Commits
b435a57d7b
...
3d3b5d6bd2
Author | SHA1 | Date |
---|---|---|
Saku Laesvuori | 3d3b5d6bd2 | |
Saku Laesvuori | 158630a6d3 | |
Saku Laesvuori | 5f48ff6f25 |
|
@ -18,11 +18,11 @@
|
|||
(or (git-predicate (string-append (current-source-directory) "/../.."))
|
||||
(const #t)))
|
||||
|
||||
(define-public datarekisteri-server
|
||||
(define-public datarekisteri-backend
|
||||
(package
|
||||
(name "datarekisteri-server")
|
||||
(name "datarekisteri-backend")
|
||||
(version "0.0.1")
|
||||
(source (local-file "../../server" "datarekisteri-server-checkout"
|
||||
(source (local-file "../../backend" "datarekisteri-backend-checkout"
|
||||
#:recursive? #t
|
||||
#:select? vcs-file?))
|
||||
(build-system haskell-build-system)
|
||||
|
@ -30,6 +30,7 @@
|
|||
ghc-base64
|
||||
ghc-cryptonite
|
||||
ghc-datarekisteri-core
|
||||
ghc-echo
|
||||
ghc-email-validate
|
||||
ghc-esqueleto
|
||||
ghc-mime-mail
|
||||
|
@ -48,18 +49,18 @@
|
|||
(add-after 'install 'wrap-binaries
|
||||
(lambda _
|
||||
(wrap-program
|
||||
(string-append #$output "/bin/datarekisteri-server")
|
||||
(string-append #$output "/bin/datarekisteri-backend")
|
||||
`("PATH" prefix (,(string-append #$(this-package-input "dbmate") "/bin")))))))))
|
||||
(home-page "")
|
||||
(synopsis "")
|
||||
(description "")
|
||||
(license license:agpl3+)))
|
||||
|
||||
(define-public datarekisteri-client
|
||||
(define-public datarekisteri-frontend
|
||||
(package
|
||||
(name "datarekisteri-client")
|
||||
(name "datarekisteri-frontend")
|
||||
(version "0.0.1")
|
||||
(source (local-file "../../client" "datarekisteri-client-checkout"
|
||||
(source (local-file "../../frontend" "datarekisteri-frontend-checkout"
|
||||
#:recursive? #t
|
||||
#:select? vcs-file?))
|
||||
(build-system haskell-build-system)
|
||||
|
@ -982,4 +983,4 @@ for writing tests which print some outputs using @code{fmt} package.")
|
|||
multiple developers and your production servers.")
|
||||
(license license:expat)))
|
||||
|
||||
(list datarekisteri-server datarekisteri-client ghc-datarekisteri-core)
|
||||
(list datarekisteri-backend datarekisteri-frontend ghc-datarekisteri-core)
|
||||
|
|
|
@ -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)
|
||||
; ""))
|
||||
|
|
@ -0,0 +1,90 @@
|
|||
cabal-version: 3.6
|
||||
name: datarekisteri-backend
|
||||
version: 0.0.1
|
||||
author: Saku Laesvuori
|
||||
license: AGPL-3.0-or-later
|
||||
license-file: COPYING.md
|
||||
build-type: Simple
|
||||
stability: alpha
|
||||
data-files:
|
||||
db/migrations/*.sql
|
||||
|
||||
executable datarekisteri-backend
|
||||
build-depends:
|
||||
aeson,
|
||||
base,
|
||||
base64,
|
||||
cryptonite,
|
||||
datarekisteri-core,
|
||||
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,
|
||||
process,
|
||||
relude,
|
||||
scotty,
|
||||
smtp-mail,
|
||||
text,
|
||||
time,
|
||||
containers,
|
||||
wai,
|
||||
warp,
|
||||
wai-cors,
|
||||
wai-extra,
|
||||
directory
|
||||
main-is: Datarekisteri/Backend.hs
|
||||
other-modules:
|
||||
Datarekisteri.Backend.API,
|
||||
Datarekisteri.Backend.DB,
|
||||
Datarekisteri.Backend.DB.Queries,
|
||||
Datarekisteri.Backend.Email,
|
||||
Datarekisteri.Backend.Types,
|
||||
Datarekisteri.Backend.Utils,
|
||||
Paths_datarekisteri_backend
|
||||
autogen-modules:
|
||||
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
|
|
@ -19,18 +19,18 @@ import Network.Wai (Application)
|
|||
import Network.Wai.Handler.Warp (Port, run)
|
||||
import Network.Wai.Middleware.Cors
|
||||
import Network.Wai.Middleware.Gzip
|
||||
import Server.API
|
||||
import Server.DB
|
||||
import Server.DB.Queries (getUserByEmail, getPermissions, getToken)
|
||||
import Server.Types
|
||||
import Server.Utils (checkPassword)
|
||||
import Datarekisteri.Backend.API
|
||||
import Datarekisteri.Backend.DB
|
||||
import Datarekisteri.Backend.DB.Queries (getUserByEmail, getPermissions, getToken)
|
||||
import Datarekisteri.Backend.Types
|
||||
import Datarekisteri.Backend.Utils (checkPassword)
|
||||
import System.Directory (findExecutable)
|
||||
import System.Process (callProcess)
|
||||
import Options.Applicative hiding (header)
|
||||
import qualified Options.Applicative as O
|
||||
import Web.Scotty.Trans hiding (readEither)
|
||||
import qualified "base64" Data.ByteString.Base64 as B64 (decodeBase64)
|
||||
import Paths_datarekisteri_server
|
||||
import Paths_datarekisteri_backend
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
@ -57,7 +57,7 @@ configOpts = Config
|
|||
<$> optional (strOption (long "sender-name" <> short 'n' <> metavar "NAME" <> help "Display name for email address"))
|
||||
<*> strOption (long "address" <> short 'a' <> metavar "EMAIL" <> help "Email address to send mail"))
|
||||
<*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3100 <> help "Port to listen on")
|
||||
<*> strOption (long "db-url" <> short 'u' <> metavar "URL" <> value "postgres:///id.rekisteri" <> help "Postgresql database url")
|
||||
<*> strOption (long "db-url" <> short 'u' <> metavar "URL" <> value "postgres:///datarekisteri-backend" <> help "Postgresql database url")
|
||||
|
||||
runMigrations :: Text -> IO ()
|
||||
runMigrations dbUrl = do
|
|
@ -16,7 +16,7 @@
|
|||
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Server.API (coreApp, runApp, resolver) where
|
||||
module Datarekisteri.Backend.API (coreApp, runApp, resolver) where
|
||||
|
||||
import Relude hiding (Undefined, void, when, get)
|
||||
|
||||
|
@ -29,11 +29,11 @@ import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
|
|||
import Data.Time (nominalDay)
|
||||
import Database.Persist (Entity, entityVal, entityKey, get, (=.))
|
||||
import Datarekisteri.Core.Types
|
||||
import Server.DB
|
||||
import Server.DB.Queries
|
||||
import Server.Email (sendVerificationEmail)
|
||||
import Server.Types
|
||||
import Server.Utils
|
||||
import Datarekisteri.Backend.DB
|
||||
import Datarekisteri.Backend.DB.Queries
|
||||
import Datarekisteri.Backend.Email (sendVerificationEmail)
|
||||
import Datarekisteri.Backend.Types
|
||||
import Datarekisteri.Backend.Utils
|
||||
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
|
||||
import qualified Data.Text as T (null, chunksOf, intercalate)
|
||||
|
|
@ -12,7 +12,7 @@
|
|||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module Server.DB where
|
||||
module Datarekisteri.Backend.DB where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Text (Text)
|
||||
|
@ -21,7 +21,7 @@ import Database.Persist (Entity, Key, entityKey, PersistEntity)
|
|||
import Database.Persist.Sql (fromSqlKey, toSqlKey)
|
||||
import Database.Persist.Postgresql.JSON (Value)
|
||||
import Datarekisteri.Core.Types
|
||||
import Server.Types
|
||||
import Datarekisteri.Backend.Types
|
||||
|
||||
mkPersist sqlSettings [persistUpperCase|
|
||||
DBUser sql=users
|
|
@ -4,10 +4,10 @@
|
|||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Server.DB.Queries where
|
||||
module Datarekisteri.Backend.DB.Queries where
|
||||
|
||||
import Server.DB as DB
|
||||
import Server.Types
|
||||
import Datarekisteri.Backend.DB as DB
|
||||
import Datarekisteri.Backend.Types
|
||||
import Datarekisteri.Core.Types
|
||||
import Data.Text (Text)
|
||||
import Database.Esqueleto.Experimental
|
|
@ -1,8 +1,8 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Server.Email where
|
||||
module Datarekisteri.Backend.Email where
|
||||
|
||||
import Server.Types
|
||||
import Datarekisteri.Backend.Types
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Lazy (fromStrict)
|
||||
import Datarekisteri.Core.Types
|
|
@ -9,7 +9,7 @@
|
|||
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Server.Types where
|
||||
module Datarekisteri.Backend.Types where
|
||||
|
||||
import Relude
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
{-# LANGUAGE PackageImports #-}
|
||||
|
||||
module Server.Utils where
|
||||
module Datarekisteri.Backend.Utils where
|
||||
|
||||
import Data.ByteArray.Encoding (convertToBase, Base(..))
|
||||
import Data.ByteString (ByteString)
|
||||
|
@ -8,7 +8,7 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
|||
import Data.Text (Text)
|
||||
import qualified Crypto.KDF.BCrypt as Crypt (hashPassword, validatePassword)
|
||||
import "cryptonite" Crypto.Random (MonadRandom)
|
||||
import Server.Types
|
||||
import Datarekisteri.Backend.Types
|
||||
|
||||
base32 :: ByteString -> Text
|
||||
base32 = decodeUtf8 . convertToBase Base32
|
|
@ -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
|
|
@ -1,31 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Client.Handlers
|
||||
( module Client.Handlers.Profile
|
||||
, module Client.Handlers.Apply
|
||||
, module Client.Handlers.Applications
|
||||
, module Client.Handlers.VerifyEmail
|
||||
, module Client.Handlers.Members
|
||||
, getHomeR
|
||||
) where
|
||||
|
||||
import Relude
|
||||
|
||||
import Client.Handlers.Profile
|
||||
import Client.Handlers.Apply
|
||||
import Client.Handlers.Applications
|
||||
import Client.Handlers.VerifyEmail
|
||||
import Client.Handlers.Members
|
||||
import Client.Types
|
||||
import Yesod
|
||||
import Yesod.Auth
|
||||
|
||||
getHomeR :: Handler Html
|
||||
getHomeR = ifM (isJust <$> maybeAuthId) (redirect OwnProfileR) (redirect $ AuthR LoginR)
|
|
@ -1,5 +1,5 @@
|
|||
cabal-version: 3.6
|
||||
name: datarekisteri-client
|
||||
name: datarekisteri-frontend
|
||||
version: 0.0.1
|
||||
author: Saku Laesvuori
|
||||
license: AGPL-3.0-or-later
|
||||
|
@ -7,7 +7,7 @@ license-file: COPYING.md
|
|||
build-type: Simple
|
||||
stability: alpha
|
||||
|
||||
executable datarekisteri-client
|
||||
executable datarekisteri-frontend
|
||||
build-depends:
|
||||
aeson,
|
||||
base,
|
||||
|
@ -35,17 +35,17 @@ executable datarekisteri-client
|
|||
yesod-core,
|
||||
yesod-static,
|
||||
directory
|
||||
main-is: Client.hs
|
||||
main-is: Datarekisteri/Frontend.hs
|
||||
other-modules:
|
||||
Client.ApiRequests,
|
||||
Client.Auth,
|
||||
Client.FormFields,
|
||||
Client.Handlers,
|
||||
Client.Handlers.Applications,
|
||||
Client.Handlers.Apply,
|
||||
Client.Handlers.Profile,
|
||||
Client.Handlers.VerifyEmail,
|
||||
Client.Handlers.Members,
|
||||
Client.Types
|
||||
Datarekisteri.Frontend.ApiRequests,
|
||||
Datarekisteri.Frontend.Auth,
|
||||
Datarekisteri.Frontend.FormFields,
|
||||
Datarekisteri.Frontend.Handlers,
|
||||
Datarekisteri.Frontend.Handlers.Applications,
|
||||
Datarekisteri.Frontend.Handlers.Apply,
|
||||
Datarekisteri.Frontend.Handlers.Profile,
|
||||
Datarekisteri.Frontend.Handlers.VerifyEmail,
|
||||
Datarekisteri.Frontend.Handlers.Members,
|
||||
Datarekisteri.Frontend.Types
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
|
@ -15,9 +15,9 @@ import Relude hiding (get)
|
|||
|
||||
import Yesod
|
||||
import Yesod.Auth
|
||||
import Client.Types
|
||||
import Client.Handlers
|
||||
import Client.Auth ()
|
||||
import Datarekisteri.Frontend.Types
|
||||
import Datarekisteri.Frontend.Handlers
|
||||
import Datarekisteri.Frontend.Auth ()
|
||||
import Yesod.Static (static, Static)
|
||||
import Options.Applicative
|
||||
import System.Directory (createDirectoryIfMissing)
|
|
@ -9,7 +9,7 @@
|
|||
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Client.ApiRequests where
|
||||
module Datarekisteri.Frontend.ApiRequests where
|
||||
|
||||
import Relude
|
||||
|
|
@ -10,7 +10,7 @@
|
|||
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Client.Auth where
|
||||
module Datarekisteri.Frontend.Auth where
|
||||
|
||||
import Relude
|
||||
|
|
@ -3,12 +3,12 @@
|
|||
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Client.FormFields where
|
||||
module Datarekisteri.Frontend.FormFields where
|
||||
|
||||
import Relude
|
||||
|
||||
import Yesod
|
||||
import Client.Types
|
||||
import Datarekisteri.Frontend.Types
|
||||
import Datarekisteri.Core.Types
|
||||
|
||||
emailField :: Field Handler Email
|
|
@ -0,0 +1,31 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Datarekisteri.Frontend.Handlers
|
||||
( module Datarekisteri.Frontend.Handlers.Profile
|
||||
, module Datarekisteri.Frontend.Handlers.Apply
|
||||
, module Datarekisteri.Frontend.Handlers.Applications
|
||||
, module Datarekisteri.Frontend.Handlers.VerifyEmail
|
||||
, module Datarekisteri.Frontend.Handlers.Members
|
||||
, getHomeR
|
||||
) where
|
||||
|
||||
import Relude
|
||||
|
||||
import Datarekisteri.Frontend.Handlers.Profile
|
||||
import Datarekisteri.Frontend.Handlers.Apply
|
||||
import Datarekisteri.Frontend.Handlers.Applications
|
||||
import Datarekisteri.Frontend.Handlers.VerifyEmail
|
||||
import Datarekisteri.Frontend.Handlers.Members
|
||||
import Datarekisteri.Frontend.Types
|
||||
import Yesod
|
||||
import Yesod.Auth
|
||||
|
||||
getHomeR :: Handler Html
|
||||
getHomeR = ifM (isJust <$> maybeAuthId) (redirect OwnProfileR) (redirect $ AuthR LoginR)
|
|
@ -10,17 +10,17 @@
|
|||
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Client.Handlers.Applications where
|
||||
module Datarekisteri.Frontend.Handlers.Applications where
|
||||
|
||||
import Relude hiding (id)
|
||||
|
||||
import Client.ApiRequests
|
||||
import Client.Types
|
||||
import Datarekisteri.Frontend.ApiRequests
|
||||
import Datarekisteri.Frontend.Types
|
||||
import Data.Morpheus.Client
|
||||
import Datarekisteri.Core.Types hiding (Applications)
|
||||
import Yesod hiding (emailField)
|
||||
import Yesod.Auth
|
||||
import Client.FormFields
|
||||
import Datarekisteri.Frontend.FormFields
|
||||
import Data.Time (Day)
|
||||
import Data.Maybe (fromJust)
|
||||
|
|
@ -10,17 +10,17 @@
|
|||
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Client.Handlers.Apply where
|
||||
module Datarekisteri.Frontend.Handlers.Apply where
|
||||
|
||||
import Relude hiding (id)
|
||||
|
||||
import Client.ApiRequests
|
||||
import Client.Types
|
||||
import Datarekisteri.Frontend.ApiRequests
|
||||
import Datarekisteri.Frontend.Types
|
||||
import Data.Morpheus.Client
|
||||
import Datarekisteri.Core.Types
|
||||
import Yesod hiding (emailField)
|
||||
import Yesod.Auth
|
||||
import Client.FormFields
|
||||
import Datarekisteri.Frontend.FormFields
|
||||
import Data.Time (Day)
|
||||
|
||||
declareLocalTypesInline "schema.gql" [raw|
|
|
@ -8,13 +8,13 @@
|
|||
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Client.Handlers.Members where
|
||||
module Datarekisteri.Frontend.Handlers.Members where
|
||||
|
||||
import Relude hiding (id)
|
||||
|
||||
import Data.Morpheus.Client
|
||||
import Client.Types
|
||||
import Client.ApiRequests
|
||||
import Datarekisteri.Frontend.Types
|
||||
import Datarekisteri.Frontend.ApiRequests
|
||||
import Datarekisteri.Core.Types
|
||||
import Yesod
|
||||
import Yesod.Auth
|
|
@ -10,13 +10,13 @@
|
|||
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Client.Handlers.Profile where
|
||||
module Datarekisteri.Frontend.Handlers.Profile where
|
||||
|
||||
import Relude hiding (id)
|
||||
|
||||
import Client.ApiRequests
|
||||
import Client.Types
|
||||
import Client.FormFields
|
||||
import Datarekisteri.Frontend.ApiRequests
|
||||
import Datarekisteri.Frontend.Types
|
||||
import Datarekisteri.Frontend.FormFields
|
||||
import Data.Morpheus.Client
|
||||
import Datarekisteri.Core.Types
|
||||
import Yesod hiding (emailField)
|
|
@ -9,12 +9,12 @@
|
|||
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Client.Handlers.VerifyEmail where
|
||||
module Datarekisteri.Frontend.Handlers.VerifyEmail where
|
||||
|
||||
import Relude
|
||||
|
||||
import Client.ApiRequests
|
||||
import Client.Types
|
||||
import Datarekisteri.Frontend.ApiRequests
|
||||
import Datarekisteri.Frontend.Types
|
||||
import Datarekisteri.Core.Types
|
||||
import Data.Morpheus.Client
|
||||
import Yesod
|
|
@ -13,7 +13,7 @@
|
|||
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Client.Types where
|
||||
module Datarekisteri.Frontend.Types where
|
||||
|
||||
import Relude hiding (id)
|
||||
import Relude.Extra.Foldable1 (maximum1)
|
||||
|
@ -26,8 +26,8 @@ import Yesod.Static
|
|||
import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), readPermission)
|
||||
import Data.Time (getCurrentTime)
|
||||
import Data.Time.Format.ISO8601 (iso8601Show)
|
||||
import Client.Auth
|
||||
import Client.ApiRequests
|
||||
import Datarekisteri.Frontend.Auth
|
||||
import Datarekisteri.Frontend.ApiRequests
|
||||
import Data.Morpheus.Client
|
||||
import Data.Map (findWithDefault)
|
||||
|
|
@ -1,56 +0,0 @@
|
|||
cabal-version: 3.6
|
||||
name: datarekisteri-server
|
||||
version: 0.0.1
|
||||
author: Saku Laesvuori
|
||||
license: AGPL-3.0-or-later
|
||||
license-file: COPYING.md
|
||||
build-type: Simple
|
||||
stability: alpha
|
||||
data-files:
|
||||
db/migrations/*.sql
|
||||
|
||||
executable datarekisteri-server
|
||||
build-depends:
|
||||
aeson,
|
||||
base,
|
||||
base64,
|
||||
cryptonite,
|
||||
datarekisteri-core,
|
||||
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,
|
||||
process,
|
||||
relude,
|
||||
scotty,
|
||||
smtp-mail,
|
||||
text,
|
||||
time,
|
||||
containers,
|
||||
wai,
|
||||
warp,
|
||||
wai-cors,
|
||||
wai-extra,
|
||||
directory
|
||||
main-is: Server.hs
|
||||
other-modules:
|
||||
Server.API,
|
||||
Server.DB,
|
||||
Server.DB.Queries,
|
||||
Server.Email,
|
||||
Server.Types,
|
||||
Server.Utils,
|
||||
Paths_datarekisteri_server
|
||||
autogen-modules:
|
||||
Paths_datarekisteri_server
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
Loading…
Reference in New Issue