Add CLI for admin operations

.guix/modules/datarekisteri-package.scm

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

.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

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

backend/src/Datarekisteri/Backend.hs

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

backend/src/Datarekisteri/Backend/API.hs

@@ -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 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 Data.Text as T (null, chunksOf, intercalate)
 

backend/src/Datarekisteri/Backend/DB.hs

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

backend/src/Datarekisteri/Backend/DB/Queries.hs

@@ -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 Datarekisteri.Backend.DB as DB
-import Server.Types
+import Datarekisteri.Backend.Types
 import Datarekisteri.Core.Types
 import Data.Text (Text)
 import Database.Esqueleto.Experimental

backend/src/Datarekisteri/Backend/Email.hs

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

backend/src/Datarekisteri/Backend/Types.hs

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

backend/src/Datarekisteri/Backend/Utils.hs

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

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

client/src/Client/Handlers.hs

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

frontend/datarekisteri-frontend.cabal

@@ -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,
+    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
   default-language: Haskell2010

frontend/src/Datarekisteri/Frontend.hs

@@ -15,9 +15,9 @@ import Relude hiding (get)
 
 import Yesod
 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 Options.Applicative
 import System.Directory (createDirectoryIfMissing)

frontend/src/Datarekisteri/Frontend/ApiRequests.hs

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

frontend/src/Datarekisteri/Frontend/Auth.hs

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

frontend/src/Datarekisteri/Frontend/FormFields.hs

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

frontend/src/Datarekisteri/Frontend/Handlers.hs

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

frontend/src/Datarekisteri/Frontend/Handlers/Applications.hs

@@ -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 Datarekisteri.Frontend.ApiRequests
-import Client.Types
+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)
 

frontend/src/Datarekisteri/Frontend/Handlers/Apply.hs

@@ -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 Datarekisteri.Frontend.ApiRequests
-import Client.Types
+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|

frontend/src/Datarekisteri/Frontend/Handlers/Members.hs

@@ -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 Datarekisteri.Frontend.Types
-import Client.ApiRequests
+import Datarekisteri.Frontend.ApiRequests
 import Datarekisteri.Core.Types
 import Yesod
 import Yesod.Auth

frontend/src/Datarekisteri/Frontend/Handlers/Profile.hs

@@ -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 Datarekisteri.Frontend.ApiRequests
-import Client.Types
+import Datarekisteri.Frontend.Types
-import Client.FormFields
+import Datarekisteri.Frontend.FormFields
 import Data.Morpheus.Client
 import Datarekisteri.Core.Types
 import Yesod hiding (emailField)

frontend/src/Datarekisteri/Frontend/Handlers/VerifyEmail.hs

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

frontend/src/Datarekisteri/Frontend/Types.hs

@@ -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 Datarekisteri.Frontend.Auth
-import Client.ApiRequests
+import Datarekisteri.Frontend.ApiRequests
 import Data.Morpheus.Client
 import Data.Map (findWithDefault)
 

server/datarekisteri-server.cabal

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