Compare commits

...

3 Commits

33 changed files with 485 additions and 159 deletions

View File

@ -18,11 +18,11 @@
(or (git-predicate (string-append (current-source-directory) "/../..")) (or (git-predicate (string-append (current-source-directory) "/../.."))
(const #t))) (const #t)))
(define-public datarekisteri-server (define-public datarekisteri-backend
(package (package
(name "datarekisteri-server") (name "datarekisteri-backend")
(version "0.0.1") (version "0.0.1")
(source (local-file "../../server" "datarekisteri-server-checkout" (source (local-file "../../backend" "datarekisteri-backend-checkout"
#:recursive? #t #:recursive? #t
#:select? vcs-file?)) #:select? vcs-file?))
(build-system haskell-build-system) (build-system haskell-build-system)
@ -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
@ -48,18 +49,18 @@
(add-after 'install 'wrap-binaries (add-after 'install 'wrap-binaries
(lambda _ (lambda _
(wrap-program (wrap-program
(string-append #$output "/bin/datarekisteri-server") (string-append #$output "/bin/datarekisteri-backend")
`("PATH" prefix (,(string-append #$(this-package-input "dbmate") "/bin"))))))))) `("PATH" prefix (,(string-append #$(this-package-input "dbmate") "/bin")))))))))
(home-page "") (home-page "")
(synopsis "") (synopsis "")
(description "") (description "")
(license license:agpl3+))) (license license:agpl3+)))
(define-public datarekisteri-client (define-public datarekisteri-frontend
(package (package
(name "datarekisteri-client") (name "datarekisteri-frontend")
(version "0.0.1") (version "0.0.1")
(source (local-file "../../client" "datarekisteri-client-checkout" (source (local-file "../../frontend" "datarekisteri-frontend-checkout"
#:recursive? #t #:recursive? #t
#:select? vcs-file?)) #:select? vcs-file?))
(build-system haskell-build-system) (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.") multiple developers and your production servers.")
(license license:expat))) (license license:expat)))
(list datarekisteri-server datarekisteri-client ghc-datarekisteri-core) (list datarekisteri-backend datarekisteri-frontend ghc-datarekisteri-core)

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

View File

@ -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

View File

@ -19,18 +19,18 @@ import Network.Wai (Application)
import Network.Wai.Handler.Warp (Port, run) import Network.Wai.Handler.Warp (Port, run)
import Network.Wai.Middleware.Cors import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.Gzip
import Server.API import Datarekisteri.Backend.API
import Server.DB import Datarekisteri.Backend.DB
import Server.DB.Queries (getUserByEmail, getPermissions, getToken) import Datarekisteri.Backend.DB.Queries (getUserByEmail, getPermissions, getToken)
import Server.Types import Datarekisteri.Backend.Types
import Server.Utils (checkPassword) import Datarekisteri.Backend.Utils (checkPassword)
import System.Directory (findExecutable) import System.Directory (findExecutable)
import System.Process (callProcess) import System.Process (callProcess)
import Options.Applicative hiding (header) import Options.Applicative hiding (header)
import qualified Options.Applicative as O import qualified Options.Applicative as O
import Web.Scotty.Trans hiding (readEither) import Web.Scotty.Trans hiding (readEither)
import qualified "base64" Data.ByteString.Base64 as B64 (decodeBase64) import qualified "base64" Data.ByteString.Base64 as B64 (decodeBase64)
import Paths_datarekisteri_server import Paths_datarekisteri_backend
main :: IO () main :: IO ()
main = do main = do
@ -57,7 +57,7 @@ configOpts = Config
<$> optional (strOption (long "sender-name" <> short 'n' <> metavar "NAME" <> help "Display name for email address")) <$> 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")) <*> 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") <*> 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 :: Text -> IO ()
runMigrations dbUrl = do runMigrations dbUrl = do

View File

@ -16,7 +16,7 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Server.API (coreApp, runApp, resolver) where module Datarekisteri.Backend.API (coreApp, runApp, resolver) where
import Relude hiding (Undefined, void, when, get) import Relude hiding (Undefined, void, when, get)
@ -29,11 +29,11 @@ import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
import Data.Time (nominalDay) import Data.Time (nominalDay)
import Database.Persist (Entity, entityVal, entityKey, get, (=.)) import Database.Persist (Entity, entityVal, entityKey, get, (=.))
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Server.DB import Datarekisteri.Backend.DB
import Server.DB.Queries import Datarekisteri.Backend.DB.Queries
import Server.Email (sendVerificationEmail) import Datarekisteri.Backend.Email (sendVerificationEmail)
import Server.Types import Datarekisteri.Backend.Types
import Server.Utils import Datarekisteri.Backend.Utils
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64) import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
import qualified Data.Text as T (null, chunksOf, intercalate) import qualified Data.Text as T (null, chunksOf, intercalate)

View File

@ -12,7 +12,7 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
module Server.DB where module Datarekisteri.Backend.DB where
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Text (Text) import Data.Text (Text)
@ -21,7 +21,7 @@ import Database.Persist (Entity, Key, entityKey, PersistEntity)
import Database.Persist.Sql (fromSqlKey, toSqlKey) import Database.Persist.Sql (fromSqlKey, toSqlKey)
import Database.Persist.Postgresql.JSON (Value) import Database.Persist.Postgresql.JSON (Value)
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Server.Types import Datarekisteri.Backend.Types
mkPersist sqlSettings [persistUpperCase| mkPersist sqlSettings [persistUpperCase|
DBUser sql=users DBUser sql=users

View File

@ -4,10 +4,10 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Server.DB.Queries where module Datarekisteri.Backend.DB.Queries where
import Server.DB as DB import Datarekisteri.Backend.DB as DB
import Server.Types import Datarekisteri.Backend.Types
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Data.Text (Text) import Data.Text (Text)
import Database.Esqueleto.Experimental import Database.Esqueleto.Experimental

View File

@ -1,8 +1,8 @@
{-# LANGUAGE OverloadedStrings #-} {-# 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 (Text)
import Data.Text.Lazy (fromStrict) import Data.Text.Lazy (fromStrict)
import Datarekisteri.Core.Types import Datarekisteri.Core.Types

View File

@ -9,7 +9,7 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Server.Types where module Datarekisteri.Backend.Types where
import Relude import Relude

View File

@ -1,6 +1,6 @@
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
module Server.Utils where module Datarekisteri.Backend.Utils where
import Data.ByteArray.Encoding (convertToBase, Base(..)) import Data.ByteArray.Encoding (convertToBase, Base(..))
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
@ -8,7 +8,7 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Text (Text) import Data.Text (Text)
import qualified Crypto.KDF.BCrypt as Crypt (hashPassword, validatePassword) import qualified Crypto.KDF.BCrypt as Crypt (hashPassword, validatePassword)
import "cryptonite" Crypto.Random (MonadRandom) import "cryptonite" Crypto.Random (MonadRandom)
import Server.Types import Datarekisteri.Backend.Types
base32 :: ByteString -> Text base32 :: ByteString -> Text
base32 = decodeUtf8 . convertToBase Base32 base32 = decodeUtf8 . convertToBase Base32

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

View File

@ -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)

View File

@ -1,5 +1,5 @@
cabal-version: 3.6 cabal-version: 3.6
name: datarekisteri-client name: datarekisteri-frontend
version: 0.0.1 version: 0.0.1
author: Saku Laesvuori author: Saku Laesvuori
license: AGPL-3.0-or-later license: AGPL-3.0-or-later
@ -7,7 +7,7 @@ license-file: COPYING.md
build-type: Simple build-type: Simple
stability: alpha stability: alpha
executable datarekisteri-client executable datarekisteri-frontend
build-depends: build-depends:
aeson, aeson,
base, base,
@ -35,17 +35,17 @@ executable datarekisteri-client
yesod-core, yesod-core,
yesod-static, yesod-static,
directory directory
main-is: Client.hs main-is: Datarekisteri/Frontend.hs
other-modules: other-modules:
Client.ApiRequests, Datarekisteri.Frontend.ApiRequests,
Client.Auth, Datarekisteri.Frontend.Auth,
Client.FormFields, Datarekisteri.Frontend.FormFields,
Client.Handlers, Datarekisteri.Frontend.Handlers,
Client.Handlers.Applications, Datarekisteri.Frontend.Handlers.Applications,
Client.Handlers.Apply, Datarekisteri.Frontend.Handlers.Apply,
Client.Handlers.Profile, Datarekisteri.Frontend.Handlers.Profile,
Client.Handlers.VerifyEmail, Datarekisteri.Frontend.Handlers.VerifyEmail,
Client.Handlers.Members, Datarekisteri.Frontend.Handlers.Members,
Client.Types Datarekisteri.Frontend.Types
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

View File

@ -15,9 +15,9 @@ import Relude hiding (get)
import Yesod import Yesod
import Yesod.Auth import Yesod.Auth
import Client.Types import Datarekisteri.Frontend.Types
import Client.Handlers import Datarekisteri.Frontend.Handlers
import Client.Auth () import Datarekisteri.Frontend.Auth ()
import Yesod.Static (static, Static) import Yesod.Static (static, Static)
import Options.Applicative import Options.Applicative
import System.Directory (createDirectoryIfMissing) import System.Directory (createDirectoryIfMissing)

View File

@ -9,7 +9,7 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Client.ApiRequests where module Datarekisteri.Frontend.ApiRequests where
import Relude import Relude

View File

@ -10,7 +10,7 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Client.Auth where module Datarekisteri.Frontend.Auth where
import Relude import Relude

View File

@ -3,12 +3,12 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Client.FormFields where module Datarekisteri.Frontend.FormFields where
import Relude import Relude
import Yesod import Yesod
import Client.Types import Datarekisteri.Frontend.Types
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
emailField :: Field Handler Email emailField :: Field Handler Email

View File

@ -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)

View File

@ -10,17 +10,17 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Client.Handlers.Applications where module Datarekisteri.Frontend.Handlers.Applications where
import Relude hiding (id) import Relude hiding (id)
import Client.ApiRequests import Datarekisteri.Frontend.ApiRequests
import Client.Types import Datarekisteri.Frontend.Types
import Data.Morpheus.Client import Data.Morpheus.Client
import Datarekisteri.Core.Types hiding (Applications) import Datarekisteri.Core.Types hiding (Applications)
import Yesod hiding (emailField) import Yesod hiding (emailField)
import Yesod.Auth import Yesod.Auth
import Client.FormFields import Datarekisteri.Frontend.FormFields
import Data.Time (Day) import Data.Time (Day)
import Data.Maybe (fromJust) import Data.Maybe (fromJust)

View File

@ -10,17 +10,17 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Client.Handlers.Apply where module Datarekisteri.Frontend.Handlers.Apply where
import Relude hiding (id) import Relude hiding (id)
import Client.ApiRequests import Datarekisteri.Frontend.ApiRequests
import Client.Types import Datarekisteri.Frontend.Types
import Data.Morpheus.Client import Data.Morpheus.Client
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Yesod hiding (emailField) import Yesod hiding (emailField)
import Yesod.Auth import Yesod.Auth
import Client.FormFields import Datarekisteri.Frontend.FormFields
import Data.Time (Day) import Data.Time (Day)
declareLocalTypesInline "schema.gql" [raw| declareLocalTypesInline "schema.gql" [raw|

View File

@ -8,13 +8,13 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Client.Handlers.Members where module Datarekisteri.Frontend.Handlers.Members where
import Relude hiding (id) import Relude hiding (id)
import Data.Morpheus.Client import Data.Morpheus.Client
import Client.Types import Datarekisteri.Frontend.Types
import Client.ApiRequests import Datarekisteri.Frontend.ApiRequests
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Yesod import Yesod
import Yesod.Auth import Yesod.Auth

View File

@ -10,13 +10,13 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Client.Handlers.Profile where module Datarekisteri.Frontend.Handlers.Profile where
import Relude hiding (id) import Relude hiding (id)
import Client.ApiRequests import Datarekisteri.Frontend.ApiRequests
import Client.Types import Datarekisteri.Frontend.Types
import Client.FormFields import Datarekisteri.Frontend.FormFields
import Data.Morpheus.Client import Data.Morpheus.Client
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Yesod hiding (emailField) import Yesod hiding (emailField)

View File

@ -9,12 +9,12 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Client.Handlers.VerifyEmail where module Datarekisteri.Frontend.Handlers.VerifyEmail where
import Relude import Relude
import Client.ApiRequests import Datarekisteri.Frontend.ApiRequests
import Client.Types import Datarekisteri.Frontend.Types
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Data.Morpheus.Client import Data.Morpheus.Client
import Yesod import Yesod

View File

@ -13,7 +13,7 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Client.Types where module Datarekisteri.Frontend.Types where
import Relude hiding (id) import Relude hiding (id)
import Relude.Extra.Foldable1 (maximum1) import Relude.Extra.Foldable1 (maximum1)
@ -26,8 +26,8 @@ import Yesod.Static
import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), readPermission) import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), readPermission)
import Data.Time (getCurrentTime) import Data.Time (getCurrentTime)
import Data.Time.Format.ISO8601 (iso8601Show) import Data.Time.Format.ISO8601 (iso8601Show)
import Client.Auth import Datarekisteri.Frontend.Auth
import Client.ApiRequests import Datarekisteri.Frontend.ApiRequests
import Data.Morpheus.Client import Data.Morpheus.Client
import Data.Map (findWithDefault) import Data.Map (findWithDefault)

View File

@ -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