diff --git a/.cspell/dictionary.txt b/.cspell/dictionary.txt index 75a853b67..fcbab94ce 100644 --- a/.cspell/dictionary.txt +++ b/.cspell/dictionary.txt @@ -39,6 +39,7 @@ OVERLAPPABLE KHTML unlines ccall +appconfigdata # Document template example (Jinja) selectattr @@ -122,3 +123,5 @@ acche ecche dcche aste + +Pendings \ No newline at end of file diff --git a/registry-public/package.yaml b/registry-public/package.yaml index 5042dfee1..d972ca15d 100644 --- a/registry-public/package.yaml +++ b/registry-public/package.yaml @@ -1,5 +1,5 @@ name: registry-public -version: '4.30.0' +version: '4.31.0' synopsis: Registry Public description: Registry Public category: Web diff --git a/registry-server/package.yaml b/registry-server/package.yaml index 97ceb8e27..82f094c75 100644 --- a/registry-server/package.yaml +++ b/registry-server/package.yaml @@ -1,5 +1,5 @@ name: registry-server -version: '4.30.0' +version: '4.31.0' synopsis: Engine Registry description: Engine Registry category: Web diff --git a/registry-server/src/Registry/Api/Handler/ActionKey/Api.hs b/registry-server/src/Registry/Api/Handler/ActionKey/Api.hs deleted file mode 100644 index e9b1ce950..000000000 --- a/registry-server/src/Registry/Api/Handler/ActionKey/Api.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Registry.Api.Handler.ActionKey.Api where - -import Servant - -import Registry.Api.Handler.ActionKey.List_POST -import Registry.Model.Context.BaseContext - -type ActionKeyAPI = List_POST - -actionKeyApi :: Proxy ActionKeyAPI -actionKeyApi = Proxy - -actionKeyServer :: ServerT ActionKeyAPI BaseContextM -actionKeyServer = list_POST diff --git a/registry-server/src/Registry/Api/Handler/Api.hs b/registry-server/src/Registry/Api/Handler/Api.hs index b3d20044f..128203194 100644 --- a/registry-server/src/Registry/Api/Handler/Api.hs +++ b/registry-server/src/Registry/Api/Handler/Api.hs @@ -2,7 +2,6 @@ module Registry.Api.Handler.Api where import Servant -import Registry.Api.Handler.ActionKey.Api import Registry.Api.Handler.Config.Api import Registry.Api.Handler.DocumentTemplate.Api import Registry.Api.Handler.Info.Api @@ -10,11 +9,12 @@ import Registry.Api.Handler.KnowledgeModelPackage.Api import Registry.Api.Handler.Locale.Api import Registry.Api.Handler.Organization.Api import Registry.Api.Handler.PersistentCommand.Api +import Registry.Api.Handler.UserEmailLink.Api import Registry.Model.Context.BaseContext type ApplicationAPI = InfoAPI - :<|> ActionKeyAPI + :<|> UserEmailLinkAPI :<|> ConfigAPI :<|> DocumentTemplateAPI :<|> KnowledgeModelPackageAPI @@ -28,7 +28,7 @@ applicationApi = Proxy applicationServer :: ServerT ApplicationAPI BaseContextM applicationServer = infoServer - :<|> actionKeyServer + :<|> userEmailLinkServer :<|> configServer :<|> documentTemplateServer :<|> knowledgeModelPackageServer diff --git a/registry-server/src/Registry/Api/Handler/Swagger/Api.hs b/registry-server/src/Registry/Api/Handler/Swagger/Api.hs index dd51c2afa..265cc4f26 100644 --- a/registry-server/src/Registry/Api/Handler/Swagger/Api.hs +++ b/registry-server/src/Registry/Api/Handler/Swagger/Api.hs @@ -6,7 +6,6 @@ import Servant.Swagger import Servant.Swagger.UI import Registry.Api.Handler.Api -import Registry.Api.Resource.ActionKey.ActionKeySM () import Registry.Api.Resource.Config.ClientConfigSM () import Registry.Api.Resource.DocumentTemplate.DocumentTemplateDetailSM () import Registry.Api.Resource.DocumentTemplate.DocumentTemplateSimpleSM () @@ -20,6 +19,7 @@ import Registry.Api.Resource.Organization.OrganizationCreateSM () import Registry.Api.Resource.Organization.OrganizationSM () import Registry.Api.Resource.Organization.OrganizationStateSM () import Registry.Api.Resource.PersistentCommand.PersistentCommandSM () +import Registry.Api.Resource.UserEmailLink.UserEmailLinkSM () import Shared.Common.Api.Resource.Common.FileSM () import Shared.Common.Api.Resource.Common.SemVer2TupleSM () import Shared.Common.Api.Resource.Info.InfoSM () @@ -41,7 +41,7 @@ swagger = s._swaggerInfo { _infoTitle = "Registry API" , _infoDescription = Just "API specification for Registry" - , _infoVersion = "4.30.0" + , _infoVersion = "4.31.0" , _infoLicense = Just $ License diff --git a/registry-server/src/Registry/Api/Handler/UserEmailLink/Api.hs b/registry-server/src/Registry/Api/Handler/UserEmailLink/Api.hs new file mode 100644 index 000000000..152595c42 --- /dev/null +++ b/registry-server/src/Registry/Api/Handler/UserEmailLink/Api.hs @@ -0,0 +1,14 @@ +module Registry.Api.Handler.UserEmailLink.Api where + +import Servant + +import Registry.Api.Handler.UserEmailLink.List_POST +import Registry.Model.Context.BaseContext + +type UserEmailLinkAPI = List_POST + +userEmailLinkApi :: Proxy UserEmailLinkAPI +userEmailLinkApi = Proxy + +userEmailLinkServer :: ServerT UserEmailLinkAPI BaseContextM +userEmailLinkServer = list_POST diff --git a/registry-server/src/Registry/Api/Handler/ActionKey/List_POST.hs b/registry-server/src/Registry/Api/Handler/UserEmailLink/List_POST.hs similarity index 50% rename from registry-server/src/Registry/Api/Handler/ActionKey/List_POST.hs rename to registry-server/src/Registry/Api/Handler/UserEmailLink/List_POST.hs index a7074e854..f63d162dd 100644 --- a/registry-server/src/Registry/Api/Handler/ActionKey/List_POST.hs +++ b/registry-server/src/Registry/Api/Handler/UserEmailLink/List_POST.hs @@ -1,24 +1,24 @@ -module Registry.Api.Handler.ActionKey.List_POST where +module Registry.Api.Handler.UserEmailLink.List_POST where import Servant import Registry.Api.Handler.Common -import Registry.Api.Resource.ActionKey.ActionKeyJM () -import Registry.Model.ActionKey.ActionKeyType +import Registry.Api.Resource.UserEmailLink.UserEmailLinkJM () import Registry.Model.Context.BaseContext import Registry.Model.Context.ContextLenses () +import Registry.Model.UserEmailLink.UserEmailLinkType import Registry.Service.Organization.OrganizationService -import Shared.ActionKey.Api.Resource.ActionKey.ActionKeyDTO -import Shared.ActionKey.Api.Resource.ActionKey.ActionKeyJM () import Shared.Common.Api.Handler.Common import Shared.Common.Model.Context.TransactionState +import Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkDTO +import Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkJM () type List_POST = - ReqBody '[SafeJSON] (ActionKeyDTO ActionKeyType) - :> "action-keys" + ReqBody '[SafeJSON] (UserEmailLinkDTO UserEmailLinkType) + :> "user-email-links" :> Verb 'POST 201 '[SafeJSON] (Headers '[Header "x-trace-uuid" String] NoContent) -list_POST :: ActionKeyDTO ActionKeyType -> BaseContextM (Headers '[Header "x-trace-uuid" String] NoContent) +list_POST :: UserEmailLinkDTO UserEmailLinkType -> BaseContextM (Headers '[Header "x-trace-uuid" String] NoContent) list_POST reqDto = runInUnauthService Transactional $ addTraceUuidHeader =<< do diff --git a/registry-server/src/Registry/Api/Resource/ActionKey/ActionKeyJM.hs b/registry-server/src/Registry/Api/Resource/ActionKey/ActionKeyJM.hs deleted file mode 100644 index af8d3ef33..000000000 --- a/registry-server/src/Registry/Api/Resource/ActionKey/ActionKeyJM.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Registry.Api.Resource.ActionKey.ActionKeyJM where - -import Data.Aeson - -import Registry.Model.ActionKey.ActionKeyType - -instance FromJSON ActionKeyType - -instance ToJSON ActionKeyType diff --git a/registry-server/src/Registry/Api/Resource/ActionKey/ActionKeySM.hs b/registry-server/src/Registry/Api/Resource/ActionKey/ActionKeySM.hs deleted file mode 100644 index 1dae8714a..000000000 --- a/registry-server/src/Registry/Api/Resource/ActionKey/ActionKeySM.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Registry.Api.Resource.ActionKey.ActionKeySM where - -import Data.Swagger - -import Registry.Api.Resource.ActionKey.ActionKeyJM () -import Registry.Database.Migration.Development.ActionKey.Data.ActionKeys -import Registry.Model.ActionKey.ActionKeyType -import Shared.ActionKey.Api.Resource.ActionKey.ActionKeyDTO -import Shared.ActionKey.Api.Resource.ActionKey.ActionKeyJM () -import Shared.Common.Util.Swagger - -instance ToSchema ActionKeyType - -instance ToSchema (ActionKeyDTO ActionKeyType) where - declareNamedSchema = toSwagger forgottenTokenActionKeyDto diff --git a/registry-server/src/Registry/Api/Resource/UserEmailLink/UserEmailLinkJM.hs b/registry-server/src/Registry/Api/Resource/UserEmailLink/UserEmailLinkJM.hs new file mode 100644 index 000000000..2641a2c5f --- /dev/null +++ b/registry-server/src/Registry/Api/Resource/UserEmailLink/UserEmailLinkJM.hs @@ -0,0 +1,9 @@ +module Registry.Api.Resource.UserEmailLink.UserEmailLinkJM where + +import Data.Aeson + +import Registry.Model.UserEmailLink.UserEmailLinkType + +instance FromJSON UserEmailLinkType + +instance ToJSON UserEmailLinkType diff --git a/registry-server/src/Registry/Api/Resource/UserEmailLink/UserEmailLinkSM.hs b/registry-server/src/Registry/Api/Resource/UserEmailLink/UserEmailLinkSM.hs new file mode 100644 index 000000000..26763cad5 --- /dev/null +++ b/registry-server/src/Registry/Api/Resource/UserEmailLink/UserEmailLinkSM.hs @@ -0,0 +1,15 @@ +module Registry.Api.Resource.UserEmailLink.UserEmailLinkSM where + +import Data.Swagger + +import Registry.Api.Resource.UserEmailLink.UserEmailLinkJM () +import Registry.Database.Migration.Development.UserEmailLink.Data.UserEmailLinks +import Registry.Model.UserEmailLink.UserEmailLinkType +import Shared.Common.Util.Swagger +import Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkDTO +import Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkJM () + +instance ToSchema UserEmailLinkType + +instance ToSchema (UserEmailLinkDTO UserEmailLinkType) where + declareNamedSchema = toSwagger forgottenTokenUserEmailLinkDto diff --git a/registry-server/src/Registry/Database/Mapping/ActionKey/ActionKeyType.hs b/registry-server/src/Registry/Database/Mapping/ActionKey/ActionKeyType.hs deleted file mode 100644 index 8b7ced6cf..000000000 --- a/registry-server/src/Registry/Database/Mapping/ActionKey/ActionKeyType.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Registry.Database.Mapping.ActionKey.ActionKeyType where - -import Database.PostgreSQL.Simple.FromField -import Database.PostgreSQL.Simple.ToField - -import Registry.Model.ActionKey.ActionKeyType -import Shared.Common.Database.Mapping.Common - -instance ToField ActionKeyType where - toField = toFieldGenericEnum - -instance FromField ActionKeyType where - fromField = fromFieldGenericEnum diff --git a/registry-server/src/Registry/Database/Mapping/UserEmailLink/UserEmailLinkType.hs b/registry-server/src/Registry/Database/Mapping/UserEmailLink/UserEmailLinkType.hs new file mode 100644 index 000000000..57661f6c7 --- /dev/null +++ b/registry-server/src/Registry/Database/Mapping/UserEmailLink/UserEmailLinkType.hs @@ -0,0 +1,13 @@ +module Registry.Database.Mapping.UserEmailLink.UserEmailLinkType where + +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.ToField + +import Registry.Model.UserEmailLink.UserEmailLinkType +import Shared.Common.Database.Mapping.Common + +instance ToField UserEmailLinkType where + toField = toFieldGenericEnum + +instance FromField UserEmailLinkType where + fromField = fromFieldGenericEnum diff --git a/registry-server/src/Registry/Database/Migration/Development/Migration.hs b/registry-server/src/Registry/Database/Migration/Development/Migration.hs index c100aa956..656647e3a 100644 --- a/registry-server/src/Registry/Database/Migration/Development/Migration.hs +++ b/registry-server/src/Registry/Database/Migration/Development/Migration.hs @@ -2,7 +2,6 @@ module Registry.Database.Migration.Development.Migration ( runMigration, ) where -import qualified Registry.Database.Migration.Development.ActionKey.ActionKeySchemaMigration as ActionKey import qualified Registry.Database.Migration.Development.Audit.AuditSchemaMigration as Audit import qualified Registry.Database.Migration.Development.Common.CommonSchemaMigration as Common import qualified Registry.Database.Migration.Development.DocumentTemplate.DocumentTemplateMigration as DocumentTemplate @@ -14,6 +13,7 @@ import qualified Registry.Database.Migration.Development.Locale.LocaleSchemaMigr import qualified Registry.Database.Migration.Development.Organization.OrganizationMigration as Organization import qualified Registry.Database.Migration.Development.Organization.OrganizationSchemaMigration as Organization import qualified Registry.Database.Migration.Development.PersistentCommand.PersistentCommandSchemaMigration as PersistentCommand +import qualified Registry.Database.Migration.Development.UserEmailLink.UserEmailLinkSchemaMigration as UserEmailLink import Registry.Model.Context.ContextMappers import Shared.Common.Util.Logger import qualified Shared.Component.Database.Migration.Development.Component.ComponentMigration as Component @@ -30,7 +30,7 @@ runMigration = runAppContextWithBaseContext $ do PersistentCommand.dropTables DocumentTemplate.dropTables Audit.dropTables - ActionKey.dropTables + UserEmailLink.dropTables KnowledgeModelPackage.dropTables Organization.dropTables -- 3. Drop DB types @@ -40,7 +40,7 @@ runMigration = runAppContextWithBaseContext $ do -- 5. Create schema Organization.createTables KnowledgeModelPackage.createTables - ActionKey.createTables + UserEmailLink.createTables Audit.createTables DocumentTemplate.createTables PersistentCommand.createTables diff --git a/registry-server/src/Registry/Database/Migration/Development/ActionKey/Data/ActionKeys.hs b/registry-server/src/Registry/Database/Migration/Development/UserEmailLink/Data/UserEmailLinks.hs similarity index 56% rename from registry-server/src/Registry/Database/Migration/Development/ActionKey/Data/ActionKeys.hs rename to registry-server/src/Registry/Database/Migration/Development/UserEmailLink/Data/UserEmailLinks.hs index 56e294a9c..3cdc03994 100644 --- a/registry-server/src/Registry/Database/Migration/Development/ActionKey/Data/ActionKeys.hs +++ b/registry-server/src/Registry/Database/Migration/Development/UserEmailLink/Data/UserEmailLinks.hs @@ -1,34 +1,34 @@ -module Registry.Database.Migration.Development.ActionKey.Data.ActionKeys where +module Registry.Database.Migration.Development.UserEmailLink.Data.UserEmailLinks where import Data.Maybe (fromJust) import Data.Time import qualified Data.UUID as U -import Registry.Model.ActionKey.ActionKeyType +import Registry.Model.UserEmailLink.UserEmailLinkType import RegistryLib.Database.Migration.Development.Organization.Data.Organizations import RegistryLib.Model.Organization.Organization -import Shared.ActionKey.Api.Resource.ActionKey.ActionKeyDTO -import Shared.ActionKey.Model.ActionKey.ActionKey +import Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkDTO +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink -registrationActionKey = - ActionKey +registrationUserEmailLink = + UserEmailLink { uuid = fromJust . U.fromString $ "23f934f2-05b2-45d3-bce9-7675c3f3e5e9" , identity = orgGlobal.organizationId - , aType = RegistrationActionKey + , aType = RegistrationUserEmailLinkType , hash = "1ba90a0f-845e-41c7-9f1c-a55fc5a0554a" , tenantUuid = U.nil , createdAt = UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 } -forgottenTokenActionKey = - ActionKey +forgottenTokenUserEmailLink = + UserEmailLink { uuid = fromJust . U.fromString $ "2728460f-ba9a-4a05-8e47-7faa4dc931bf" , identity = orgGlobal.organizationId - , aType = ForgottenTokenActionKey + , aType = ForgottenTokenUserEmailLinkType , hash = "5b1aff0d-b5e3-436d-b913-6b52d3cbad5f" , tenantUuid = U.nil , createdAt = UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 } -forgottenTokenActionKeyDto = - ActionKeyDTO {aType = forgottenTokenActionKey.aType, email = orgGlobal.email} +forgottenTokenUserEmailLinkDto = + UserEmailLinkDTO {aType = forgottenTokenUserEmailLink.aType, email = orgGlobal.email} diff --git a/registry-server/src/Registry/Database/Migration/Development/ActionKey/ActionKeySchemaMigration.hs b/registry-server/src/Registry/Database/Migration/Development/UserEmailLink/UserEmailLinkSchemaMigration.hs similarity index 57% rename from registry-server/src/Registry/Database/Migration/Development/ActionKey/ActionKeySchemaMigration.hs rename to registry-server/src/Registry/Database/Migration/Development/UserEmailLink/UserEmailLinkSchemaMigration.hs index e06df6d0a..c05939718 100644 --- a/registry-server/src/Registry/Database/Migration/Development/ActionKey/ActionKeySchemaMigration.hs +++ b/registry-server/src/Registry/Database/Migration/Development/UserEmailLink/UserEmailLinkSchemaMigration.hs @@ -1,4 +1,4 @@ -module Registry.Database.Migration.Development.ActionKey.ActionKeySchemaMigration where +module Registry.Database.Migration.Development.UserEmailLink.UserEmailLinkSchemaMigration where import Database.PostgreSQL.Simple import GHC.Int @@ -10,16 +10,16 @@ import Shared.Common.Util.Logger dropTables :: AppContextM Int64 dropTables = do - logInfo _CMP_MIGRATION "(Table/ActionKey) drop tables" - let sql = "DROP TABLE IF EXISTS action_key CASCADE;" + logInfo _CMP_MIGRATION "(Table/UserEmailLink) drop tables" + let sql = "DROP TABLE IF EXISTS user_email_link CASCADE;" let action conn = execute_ conn sql runDB action createTables :: AppContextM Int64 createTables = do - logInfo _CMP_MIGRATION "(Table/ActionKey) create table" + logInfo _CMP_MIGRATION "(Table/UserEmailLink) create table" let sql = - "CREATE TABLE action_key \ + "CREATE TABLE user_email_link \ \( \ \ uuid uuid NOT NULL, \ \ identity varchar NOT NULL, \ @@ -27,10 +27,10 @@ createTables = do \ hash varchar NOT NULL, \ \ created_at timestamptz NOT NULL, \ \ tenant_uuid uuid NOT NULL, \ - \ CONSTRAINT action_key_pk PRIMARY KEY (uuid, tenant_uuid), \ - \ CONSTRAINT action_key_identity_fk FOREIGN KEY (identity) REFERENCES organization (organization_id) ON DELETE CASCADE \ + \ CONSTRAINT user_email_link_pk PRIMARY KEY (uuid, tenant_uuid), \ + \ CONSTRAINT user_email_link_identity_fk FOREIGN KEY (identity) REFERENCES organization (organization_id) ON DELETE CASCADE \ \); \ \ \ - \CREATE UNIQUE INDEX action_key_hash_uindex ON action_key (hash);" + \CREATE UNIQUE INDEX user_email_link_hash_uindex ON user_email_link (hash);" let action conn = execute_ conn sql runDB action diff --git a/registry-server/src/Registry/Database/Migration/Production/Migration_0018_idToUuid/Migration.hs b/registry-server/src/Registry/Database/Migration/Production/Migration_0018_idToUuid/Migration.hs index d834dfb7c..da3866586 100644 --- a/registry-server/src/Registry/Database/Migration/Production/Migration_0018_idToUuid/Migration.hs +++ b/registry-server/src/Registry/Database/Migration/Production/Migration_0018_idToUuid/Migration.hs @@ -10,12 +10,13 @@ import Database.PostgreSQL.Simple definition = (meta, migrate) -meta = MigrationMeta {mmNumber = 18, mmName = "Switch from ID to UUID", mmDescription = "Switch from ID to UUID for knowledge models and document templates"} +meta = MigrationMeta {mmNumber = 18, mmName = "Switch from ID to UUID", mmDescription = "Switch from ID to UUID for knowledge models and document templates; rename action_key table to user_email_link"} migrate :: Pool Connection -> LoggingT IO (Maybe Error) migrate dbPool = do changeDocumentTemplatePrimaryKeyFromIdToUuid dbPool changeKnowledgeModelPrimaryKeyFromIdToUuid dbPool + renameUserEmailLinkTable dbPool changeDocumentTemplatePrimaryKeyFromIdToUuid dbPool = do let sql = @@ -92,3 +93,15 @@ changeKnowledgeModelPrimaryKeyFromIdToUuid dbPool = do let action conn = execute_ conn sql liftIO $ withResource dbPool action return Nothing + +renameUserEmailLinkTable dbPool = do + let sql = + "ALTER TABLE IF EXISTS action_key RENAME TO user_email_link; \ + \ALTER TABLE IF EXISTS user_email_link RENAME CONSTRAINT action_key_pk TO user_email_link_pk; \ + \ALTER INDEX IF EXISTS action_key_uuid_uindex RENAME TO user_email_link_uuid_uindex; \ + \ALTER INDEX IF EXISTS action_key_hash_uindex RENAME TO user_email_link_hash_uindex; \ + \UPDATE user_email_link SET type = 'RegistrationUserEmailLinkType' WHERE type = 'RegistrationActionKey'; \ + \UPDATE user_email_link SET type = 'ForgottenTokenUserEmailLinkType' WHERE type = 'ForgottenTokenActionKey';" + let action conn = execute_ conn sql + liftIO $ withResource dbPool action + return Nothing diff --git a/registry-server/src/Registry/Model/ActionKey/ActionKeyType.hs b/registry-server/src/Registry/Model/ActionKey/ActionKeyType.hs deleted file mode 100644 index 21b053019..000000000 --- a/registry-server/src/Registry/Model/ActionKey/ActionKeyType.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Registry.Model.ActionKey.ActionKeyType where - -import GHC.Generics - -data ActionKeyType - = RegistrationActionKey - | ForgottenTokenActionKey - deriving (Show, Eq, Generic, Read) diff --git a/registry-server/src/Registry/Model/UserEmailLink/UserEmailLinkType.hs b/registry-server/src/Registry/Model/UserEmailLink/UserEmailLinkType.hs new file mode 100644 index 000000000..662dc59e1 --- /dev/null +++ b/registry-server/src/Registry/Model/UserEmailLink/UserEmailLinkType.hs @@ -0,0 +1,8 @@ +module Registry.Model.UserEmailLink.UserEmailLinkType where + +import GHC.Generics + +data UserEmailLinkType + = RegistrationUserEmailLinkType + | ForgottenTokenUserEmailLinkType + deriving (Show, Eq, Generic, Read) diff --git a/registry-server/src/Registry/Service/ActionKey/ActionKeyService.hs b/registry-server/src/Registry/Service/ActionKey/ActionKeyService.hs deleted file mode 100644 index abb5c9ec3..000000000 --- a/registry-server/src/Registry/Service/ActionKey/ActionKeyService.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Registry.Service.ActionKey.ActionKeyService where - -import Control.Monad.Reader (liftIO) -import Data.Time -import qualified Data.UUID as U - -import Registry.Database.Mapping.ActionKey.ActionKeyType () -import Registry.Model.ActionKey.ActionKeyType -import Registry.Model.Context.AppContext -import Registry.Model.Context.ContextLenses () -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO -import Shared.ActionKey.Model.ActionKey.ActionKey -import Shared.Common.Util.Uuid - -createActionKey :: String -> ActionKeyType -> AppContextM (ActionKey String ActionKeyType) -createActionKey orgId actionType = do - uuid <- liftIO generateUuid - hash <- liftIO generateUuid - now <- liftIO getCurrentTime - let actionKey = - ActionKey - { uuid = uuid - , identity = orgId - , aType = actionType - , hash = U.toString hash - , tenantUuid = U.nil - , createdAt = now - } - insertActionKey actionKey - return actionKey diff --git a/registry-server/src/Registry/Service/Organization/OrganizationService.hs b/registry-server/src/Registry/Service/Organization/OrganizationService.hs index 4c7ed3324..390f64320 100644 --- a/registry-server/src/Registry/Service/Organization/OrganizationService.hs +++ b/registry-server/src/Registry/Service/Organization/OrganizationService.hs @@ -9,27 +9,27 @@ import Registry.Api.Resource.Organization.OrganizationChangeDTO import Registry.Database.DAO.Common import Registry.Database.DAO.Organization.OrganizationDAO import Registry.Localization.Messages.Internal -import Registry.Model.ActionKey.ActionKeyType import Registry.Model.Config.ServerConfig import Registry.Model.Context.AppContext import Registry.Model.Context.AppContextHelpers -import Registry.Service.ActionKey.ActionKeyService +import Registry.Model.UserEmailLink.UserEmailLinkType import Registry.Service.Mail.Mailer import Registry.Service.Organization.OrganizationMapper import Registry.Service.Organization.OrganizationValidation +import Registry.Service.UserEmailLink.UserEmailLinkService import RegistryLib.Api.Resource.Organization.OrganizationCreateDTO import RegistryLib.Api.Resource.Organization.OrganizationDTO import RegistryLib.Api.Resource.Organization.OrganizationStateDTO import RegistryLib.Model.Organization.Organization import RegistryLib.Model.Organization.OrganizationRole import RegistryLib.Model.Organization.OrganizationSimple -import Shared.ActionKey.Api.Resource.ActionKey.ActionKeyDTO -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO -import Shared.ActionKey.Model.ActionKey.ActionKey import Shared.Common.Localization.Messages.Public import Shared.Common.Model.Config.ServerConfig import Shared.Common.Model.Error.Error import Shared.Common.Util.Crypto (generateRandomString) +import Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkDTO +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink getOrganizations :: AppContextM [OrganizationDTO] getOrganizations = do @@ -48,9 +48,9 @@ createOrganization reqDto mCallbackUrl = now <- liftIO getCurrentTime let org = fromCreateDTO reqDto UserRole token now now now insertOrganization org - actionKey <- createActionKey org.organizationId RegistrationActionKey + userEmailLink <- createUserEmailLink org.organizationId RegistrationUserEmailLinkType _ <- - sendRegistrationConfirmationMail (toDTO org) actionKey.hash mCallbackUrl + sendRegistrationConfirmationMail (toDTO org) userEmailLink.hash mCallbackUrl `catchError` (\errMessage -> throwError $ GeneralServerError _ERROR_SERVICE_ORGANIZATION__ACTIVATION_EMAIL_NOT_SENT) sendAnalyticsEmailIfEnabled org return . toDTO $ org @@ -91,34 +91,34 @@ deleteOrganization orgId = changeOrganizationTokenByHash :: String -> String -> AppContextM OrganizationDTO changeOrganizationTokenByHash orgId hash = runInTransaction $ do - actionKey <- findActionKeyByHash hash :: AppContextM (ActionKey String ActionKeyType) - org <- findOrganizationByOrgId actionKey.identity + userEmailLink <- findUserEmailLinkByHash hash :: AppContextM (UserEmailLink String UserEmailLinkType) + org <- findOrganizationByOrgId userEmailLink.identity orgToken <- generateNewOrgToken now <- liftIO getCurrentTime let updatedOrg = org {token = orgToken, updatedAt = now} :: Organization updateOrganization updatedOrg - deleteActionKeyByHash actionKey.hash + deleteUserEmailLinkByHash userEmailLink.hash return . toDTO $ updatedOrg -resetOrganizationToken :: ActionKeyDTO ActionKeyType -> AppContextM () +resetOrganizationToken :: UserEmailLinkDTO UserEmailLinkType -> AppContextM () resetOrganizationToken reqDto = runInTransaction $ do validateOrganizationEmailExistence reqDto.email org <- findOrganizationByEmail reqDto.email - actionKey <- createActionKey org.organizationId ForgottenTokenActionKey + userEmailLink <- createUserEmailLink org.organizationId ForgottenTokenUserEmailLinkType _ <- - sendResetTokenMail (toDTO org) actionKey.hash + sendResetTokenMail (toDTO org) userEmailLink.hash `catchError` (\errMessage -> throwError $ GeneralServerError _ERROR_SERVICE_ORGANIZATION__RECOVERY_EMAIL_NOT_SENT) return () changeOrganizationState :: String -> String -> OrganizationStateDTO -> AppContextM OrganizationDTO changeOrganizationState orgId hash reqDto = runInTransaction $ do - actionKey <- findActionKeyByHash hash :: AppContextM (ActionKey String ActionKeyType) - org <- findOrganizationByOrgId actionKey.identity + userEmailLink <- findUserEmailLinkByHash hash :: AppContextM (UserEmailLink String UserEmailLinkType) + org <- findOrganizationByOrgId userEmailLink.identity updatedOrg <- updateOrgTimestamp $ org {active = reqDto.active} updateOrganization updatedOrg - deleteActionKeyByHash actionKey.hash + deleteUserEmailLinkByHash userEmailLink.hash return . toDTO $ updatedOrg -- -------------------------------- diff --git a/registry-server/src/Registry/Service/UserEmailLink/UserEmailLinkService.hs b/registry-server/src/Registry/Service/UserEmailLink/UserEmailLinkService.hs new file mode 100644 index 000000000..05161a67a --- /dev/null +++ b/registry-server/src/Registry/Service/UserEmailLink/UserEmailLinkService.hs @@ -0,0 +1,30 @@ +module Registry.Service.UserEmailLink.UserEmailLinkService where + +import Control.Monad.Reader (liftIO) +import Data.Time +import qualified Data.UUID as U + +import Registry.Database.Mapping.UserEmailLink.UserEmailLinkType () +import Registry.Model.Context.AppContext +import Registry.Model.Context.ContextLenses () +import Registry.Model.UserEmailLink.UserEmailLinkType +import Shared.Common.Util.Uuid +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink + +createUserEmailLink :: String -> UserEmailLinkType -> AppContextM (UserEmailLink String UserEmailLinkType) +createUserEmailLink orgId actionType = do + uuid <- liftIO generateUuid + hash <- liftIO generateUuid + now <- liftIO getCurrentTime + let userEmailLink = + UserEmailLink + { uuid = uuid + , identity = orgId + , aType = actionType + , hash = U.toString hash + , tenantUuid = U.nil + , createdAt = now + } + insertUserEmailLink userEmailLink + return userEmailLink diff --git a/registry-server/src/Registry/Worker/CronWorkers.hs b/registry-server/src/Registry/Worker/CronWorkers.hs index 9596d37fd..fe719c3d7 100644 --- a/registry-server/src/Registry/Worker/CronWorkers.hs +++ b/registry-server/src/Registry/Worker/CronWorkers.hs @@ -6,13 +6,11 @@ import Registry.Model.Context.BaseContext import Registry.Model.Context.ContextLenses () import Registry.Service.PersistentCommand.PersistentCommandService import Shared.Common.Model.Config.ServerConfig -import Shared.PersistentCommand.Service.PersistentCommand.PersistentCommandService import Shared.Worker.Model.Worker.CronWorker workers :: [CronWorker BaseContext AppContextM] workers = [ persistentCommandRetryWorker - , persistentCommandRetryLambdaWorker ] -- ------------------------------------------------------------------ @@ -26,14 +24,3 @@ persistentCommandRetryWorker = , function = runPersistentCommands' , wrapInTransaction = False } - -persistentCommandRetryLambdaWorker :: CronWorker BaseContext AppContextM -persistentCommandRetryLambdaWorker = - CronWorker - { name = "persistentCommandRetryLambdaWorker" - , condition = (.serverConfig.persistentCommand.retryLambdaJob.enabled) - , cronDefault = "* * * * *" - , cron = (.serverConfig.persistentCommand.retryLambdaJob.cron) - , function = retryPersistentCommandsForLambda - , wrapInTransaction = False - } diff --git a/registry-server/test/Registry/Specs/API/Organization/Detail_State_PUT.hs b/registry-server/test/Registry/Specs/API/Organization/Detail_State_PUT.hs index 97a9e2d46..bfc57c11f 100644 --- a/registry-server/test/Registry/Specs/API/Organization/Detail_State_PUT.hs +++ b/registry-server/test/Registry/Specs/API/Organization/Detail_State_PUT.hs @@ -9,7 +9,7 @@ import Test.Hspec import Test.Hspec.Wai import Registry.Database.DAO.Organization.OrganizationDAO -import Registry.Database.Migration.Development.ActionKey.Data.ActionKeys +import Registry.Database.Migration.Development.UserEmailLink.Data.UserEmailLinks import Registry.Model.Context.AppContext import Registry.Service.Organization.OrganizationMapper import RegistryLib.Api.Resource.Organization.OrganizationDTO @@ -17,8 +17,8 @@ import RegistryLib.Api.Resource.Organization.OrganizationJM () import RegistryLib.Api.Resource.Organization.OrganizationStateJM () import RegistryLib.Database.Migration.Development.Organization.Data.Organizations import RegistryLib.Model.Organization.Organization -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO import Shared.Common.Api.Resource.Error.ErrorJM () +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO import Registry.Specs.API.Common import Registry.Specs.API.Organization.Common @@ -60,7 +60,7 @@ test_200 appContext = let expDto = toDTO orgGlobal let expType (a :: OrganizationDTO) = a -- AND: Prepare DB - runInContextIO (insertActionKey registrationActionKey) appContext + runInContextIO (insertUserEmailLink registrationUserEmailLink) appContext runInContextIO (updateOrganization (orgGlobal {active = False})) appContext -- WHEN: Call API response <- request reqMethod reqUrl reqHeaders reqBody @@ -83,5 +83,5 @@ test_404 appContext = "/organizations/global/state?hash=c996414a-b51d-4c8c-bc10-5ee3dab85fa8" reqHeaders reqBody - "action_key" + "user_email_link" [("hash", "c996414a-b51d-4c8c-bc10-5ee3dab85fa8")] diff --git a/registry-server/test/Registry/Specs/API/Organization/Detail_Token_PUT.hs b/registry-server/test/Registry/Specs/API/Organization/Detail_Token_PUT.hs index 0cd0828a8..65f450245 100644 --- a/registry-server/test/Registry/Specs/API/Organization/Detail_Token_PUT.hs +++ b/registry-server/test/Registry/Specs/API/Organization/Detail_Token_PUT.hs @@ -8,14 +8,14 @@ import Test.Hspec import Test.Hspec.Wai import Registry.Database.DAO.Organization.OrganizationDAO -import Registry.Database.Migration.Development.ActionKey.Data.ActionKeys +import Registry.Database.Migration.Development.UserEmailLink.Data.UserEmailLinks import Registry.Model.Context.AppContext import Registry.Service.Organization.OrganizationMapper import RegistryLib.Api.Resource.Organization.OrganizationDTO import RegistryLib.Api.Resource.Organization.OrganizationJM () import RegistryLib.Database.Migration.Development.Organization.Data.Organizations import RegistryLib.Model.Organization.Organization -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO import Registry.Specs.API.Common import Registry.Specs.Common @@ -53,7 +53,7 @@ test_200 appContext = let expDto = toDTO orgGlobal let expType (a :: OrganizationDTO) = a -- AND: Prepare DB - runInContextIO (insertActionKey forgottenTokenActionKey) appContext + runInContextIO (insertUserEmailLink forgottenTokenUserEmailLink) appContext -- WHEN: Call API response <- request reqMethod reqUrl reqHeaders reqBody -- THEN: Compare response with expectation @@ -71,5 +71,5 @@ test_404 appContext = "/organizations/global/token?hash=c996414a-b51d-4c8c-bc10-5ee3dab85fa8" reqHeaders reqBody - "action_key" + "user_email_link" [("hash", "c996414a-b51d-4c8c-bc10-5ee3dab85fa8")] diff --git a/registry-server/test/Registry/Specs/API/ActionKey/APISpec.hs b/registry-server/test/Registry/Specs/API/UserEmailLink/APISpec.hs similarity index 58% rename from registry-server/test/Registry/Specs/API/ActionKey/APISpec.hs rename to registry-server/test/Registry/Specs/API/UserEmailLink/APISpec.hs index 79081274c..19036cf0e 100644 --- a/registry-server/test/Registry/Specs/API/ActionKey/APISpec.hs +++ b/registry-server/test/Registry/Specs/API/UserEmailLink/APISpec.hs @@ -1,10 +1,10 @@ -module Registry.Specs.API.ActionKey.APISpec where +module Registry.Specs.API.UserEmailLink.APISpec where import Test.Hspec import Test.Hspec.Wai hiding (shouldRespondWith) -import Registry.Specs.API.ActionKey.List_POST import Registry.Specs.API.Common +import Registry.Specs.API.UserEmailLink.List_POST -actionKeyAPI baseContext appContext = +userEmailLinkAPI baseContext appContext = with (startWebApp baseContext appContext) $ describe "ACTION KEY API Spec" $ list_POST appContext diff --git a/registry-server/test/Registry/Specs/API/ActionKey/List_POST.hs b/registry-server/test/Registry/Specs/API/UserEmailLink/List_POST.hs similarity index 72% rename from registry-server/test/Registry/Specs/API/ActionKey/List_POST.hs rename to registry-server/test/Registry/Specs/API/UserEmailLink/List_POST.hs index 451cc6993..65233b3da 100644 --- a/registry-server/test/Registry/Specs/API/ActionKey/List_POST.hs +++ b/registry-server/test/Registry/Specs/API/UserEmailLink/List_POST.hs @@ -1,4 +1,4 @@ -module Registry.Specs.API.ActionKey.List_POST ( +module Registry.Specs.API.UserEmailLink.List_POST ( list_POST, ) where @@ -9,28 +9,28 @@ import Test.Hspec import Test.Hspec.Wai hiding (shouldRespondWith) import Test.Hspec.Wai.Matcher -import Registry.Api.Resource.ActionKey.ActionKeyJM () -import Registry.Database.Migration.Development.ActionKey.Data.ActionKeys +import Registry.Api.Resource.UserEmailLink.UserEmailLinkJM () +import Registry.Database.Migration.Development.UserEmailLink.Data.UserEmailLinks import Registry.Localization.Messages.Public -import Registry.Model.ActionKey.ActionKeyType import Registry.Model.Context.AppContext +import Registry.Model.UserEmailLink.UserEmailLinkType import RegistryLib.Database.Migration.Development.Organization.Data.Organizations import RegistryLib.Model.Organization.Organization -import Shared.ActionKey.Api.Resource.ActionKey.ActionKeyDTO -import Shared.ActionKey.Api.Resource.ActionKey.ActionKeyJM () -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO -import Shared.ActionKey.Model.ActionKey.ActionKey import Shared.Common.Model.Error.Error +import Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkDTO +import Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkJM () +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink import Registry.Specs.API.Common import SharedTest.Specs.API.Common -- ------------------------------------------------------------------------ --- POST /action-keys +-- POST /user-email-links -- ------------------------------------------------------------------------ list_POST :: AppContext -> SpecWith ((), Application) list_POST appContext = - describe "POST /action-keys" $ do + describe "POST /user-email-links" $ do test_201 appContext test_400 appContext @@ -39,11 +39,11 @@ list_POST appContext = -- ---------------------------------------------------- reqMethod = methodPost -reqUrl = "/action-keys" +reqUrl = "/user-email-links" reqHeaders = [reqCtHeader] -reqDto = forgottenTokenActionKeyDto +reqDto = forgottenTokenUserEmailLinkDto reqBody = encode reqDto @@ -64,9 +64,9 @@ test_201 appContext = ResponseMatcher {matchHeaders = expHeaders, matchStatus = expStatus, matchBody = bodyEquals expBody} response `shouldRespondWith` responseMatcher -- AND: Find result in DB and compare with expectation state - actionKeyFromDb <- getFirstFromDB findActionKeys appContext - liftIO $ actionKeyFromDb.aType `shouldBe` reqDto.aType - liftIO $ actionKeyFromDb.identity `shouldBe` orgGlobal.organizationId + userEmailLinkFromDb <- getFirstFromDB findUserEmailLinks appContext + liftIO $ userEmailLinkFromDb.aType `shouldBe` reqDto.aType + liftIO $ userEmailLinkFromDb.identity `shouldBe` orgGlobal.organizationId -- ---------------------------------------------------- -- ---------------------------------------------------- @@ -76,7 +76,7 @@ test_400 appContext = do it "HTTP 400 BAD REQUEST when email doesn't exist" $ -- GIVEN: Prepare request do - let reqDto = forgottenTokenActionKeyDto {email = "non-existing@example.com"} :: ActionKeyDTO ActionKeyType + let reqDto = forgottenTokenUserEmailLinkDto {email = "non-existing@example.com"} :: UserEmailLinkDTO UserEmailLinkType let reqBody = encode reqDto -- Prepare expectation let expStatus = 400 diff --git a/registry-server/test/Registry/TestMigration.hs b/registry-server/test/Registry/TestMigration.hs index 07b89453d..51c1114bb 100644 --- a/registry-server/test/Registry/TestMigration.hs +++ b/registry-server/test/Registry/TestMigration.hs @@ -4,7 +4,6 @@ import Data.Foldable (traverse_) import Registry.Database.DAO.Audit.AuditEntryDAO import Registry.Database.DAO.Organization.OrganizationDAO -import qualified Registry.Database.Migration.Development.ActionKey.ActionKeySchemaMigration as ActionKey import qualified Registry.Database.Migration.Development.Audit.AuditSchemaMigration as Audit import qualified Registry.Database.Migration.Development.Common.CommonSchemaMigration as Common import qualified Registry.Database.Migration.Development.DocumentTemplate.DocumentTemplateSchemaMigration as DocumentTemplate @@ -12,8 +11,8 @@ import qualified Registry.Database.Migration.Development.KnowledgeModel.Knowledg import qualified Registry.Database.Migration.Development.Locale.LocaleSchemaMigration as Locale import qualified Registry.Database.Migration.Development.Organization.OrganizationSchemaMigration as Organization import qualified Registry.Database.Migration.Development.PersistentCommand.PersistentCommandSchemaMigration as PersistentCommand +import qualified Registry.Database.Migration.Development.UserEmailLink.UserEmailLinkSchemaMigration as UserEmailLink import RegistryLib.Database.Migration.Development.Organization.Data.Organizations -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO import Shared.Component.Database.DAO.Component.ComponentDAO import qualified Shared.Component.Database.Migration.Development.Component.ComponentSchemaMigration as Component import Shared.DocumentTemplate.Database.DAO.DocumentTemplate.DocumentTemplateDAO @@ -22,6 +21,7 @@ import Shared.KnowledgeModel.Database.DAO.Package.KnowledgeModelPackageEventDAO import Shared.KnowledgeModel.Database.Migration.Development.KnowledgeModel.Data.Package.KnowledgeModelPackages import Shared.Locale.Database.DAO.Locale.LocaleDAO import Shared.PersistentCommand.Database.DAO.PersistentCommand.PersistentCommandDAO +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO import Registry.Specs.Common @@ -32,7 +32,7 @@ buildSchema appContext = runInContext Component.dropTables appContext runInContext Locale.dropTables appContext runInContext PersistentCommand.dropTables appContext - runInContext ActionKey.dropTables appContext + runInContext UserEmailLink.dropTables appContext runInContext Audit.dropTables appContext runInContext Organization.dropTables appContext runInContext KnowledgeModelPackage.dropTables appContext @@ -45,7 +45,7 @@ buildSchema appContext = putStrLn "DB: Creating schema" runInContext Organization.createTables appContext runInContext KnowledgeModelPackage.createTables appContext - runInContext ActionKey.createTables appContext + runInContext UserEmailLink.createTables appContext runInContext Audit.createTables appContext runInContext DocumentTemplate.createTables appContext runInContext PersistentCommand.createTables appContext @@ -54,7 +54,7 @@ buildSchema appContext = resetDB appContext = do runInContext deletePersistentCommands appContext - runInContext deleteActionKeys appContext + runInContext deleteUserEmailLinks appContext runInContext deleteAuditEntries appContext runInContext deletePackages appContext runInContext deleteDocumentTemplates appContext diff --git a/registry-server/test/Spec.hs b/registry-server/test/Spec.hs index 7c1ba5dd7..23b7efc7e 100644 --- a/registry-server/test/Spec.hs +++ b/registry-server/test/Spec.hs @@ -1,5 +1,7 @@ module Main where +import Control.Monad ((>=>)) +import qualified Data.ByteString as BS import Data.Maybe (fromJust) import Data.Pool import qualified Data.UUID as U @@ -20,13 +22,13 @@ import Shared.Common.S3.Common import Shared.Common.Service.Config.BuildInfo.BuildInfoConfigService import Shared.Common.Service.Config.Server.ServerConfigService -import Registry.Specs.API.ActionKey.APISpec import Registry.Specs.API.Config.APISpec import Registry.Specs.API.DocumentTemplate.APISpec import Registry.Specs.API.Info.APISpec import Registry.Specs.API.KnowledgeModelPackage.APISpec import Registry.Specs.API.Locale.APISpec import Registry.Specs.API.Organization.APISpec +import Registry.Specs.API.UserEmailLink.APISpec import Registry.Specs.Service.KnowledgeModel.Package.PackageValidationSpec import Registry.TestMigration @@ -42,7 +44,7 @@ hLoadConfig fileName loadFn callback = do callback config prepareWebApp runCallback = - hLoadConfig serverConfigFileTest (getServerConfig validateServerConfig) $ \serverConfig -> + hLoadConfig serverConfigFileTest (BS.readFile >=> getServerConfig validateServerConfig) $ \serverConfig -> hLoadConfig buildInfoConfigFileTest getBuildInfoConfig $ \buildInfoConfig -> do putStrLn $ "ENVIRONMENT: set to " `mappend` serverConfig.general.environment dbPool <- createDatabaseConnectionPool serverConfig.database @@ -85,7 +87,7 @@ main = "Package" packageValidationSpec before (resetDB appContext) $ describe "INTEGRATION TESTING" $ describe "API" $ do - actionKeyAPI baseContext appContext + userEmailLinkAPI baseContext appContext configAPI baseContext appContext infoAPI baseContext appContext knowledgeModelPackageAPI baseContext appContext diff --git a/shared-common/package.yaml b/shared-common/package.yaml index e2bc1e939..764427bbc 100644 --- a/shared-common/package.yaml +++ b/shared-common/package.yaml @@ -1,5 +1,5 @@ name: shared-common -version: '4.30.0' +version: '4.31.0' synopsis: Engine Shared description: Engine Shared category: Web @@ -24,6 +24,7 @@ library: - base - aeson - amazonka + - amazonka-appconfigdata - amazonka-lambda - async - attoparsec diff --git a/shared-common/src/Shared/ActionKey/Api/Resource/ActionKey/ActionKeyDTO.hs b/shared-common/src/Shared/ActionKey/Api/Resource/ActionKey/ActionKeyDTO.hs deleted file mode 100644 index 2d58fb7c3..000000000 --- a/shared-common/src/Shared/ActionKey/Api/Resource/ActionKey/ActionKeyDTO.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Shared.ActionKey.Api.Resource.ActionKey.ActionKeyDTO where - -import GHC.Generics - -data ActionKeyDTO aType = ActionKeyDTO - { aType :: aType - , email :: String - } - deriving (Show, Eq, Generic) diff --git a/shared-common/src/Shared/ActionKey/Api/Resource/ActionKey/ActionKeyJM.hs b/shared-common/src/Shared/ActionKey/Api/Resource/ActionKey/ActionKeyJM.hs deleted file mode 100644 index fbf7cd728..000000000 --- a/shared-common/src/Shared/ActionKey/Api/Resource/ActionKey/ActionKeyJM.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Shared.ActionKey.Api.Resource.ActionKey.ActionKeyJM where - -import Data.Aeson - -import Shared.ActionKey.Api.Resource.ActionKey.ActionKeyDTO -import Shared.Common.Util.Aeson - -instance FromJSON aType => FromJSON (ActionKeyDTO aType) where - parseJSON = genericParseJSON jsonOptions - -instance ToJSON aType => ToJSON (ActionKeyDTO aType) where - toJSON = genericToJSON jsonOptions diff --git a/shared-common/src/Shared/ActionKey/Database/DAO/ActionKey/ActionKeyDAO.hs b/shared-common/src/Shared/ActionKey/Database/DAO/ActionKey/ActionKeyDAO.hs deleted file mode 100644 index 2c7bf20a7..000000000 --- a/shared-common/src/Shared/ActionKey/Database/DAO/ActionKey/ActionKeyDAO.hs +++ /dev/null @@ -1,79 +0,0 @@ -module Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO where - -import Control.Monad.Reader (asks) -import Data.String -import Data.Time -import Database.PostgreSQL.Simple -import Database.PostgreSQL.Simple.FromField -import Database.PostgreSQL.Simple.ToField -import GHC.Int - -import Shared.ActionKey.Database.Mapping.ActionKey.ActionKey () -import Shared.ActionKey.Model.ActionKey.ActionKey -import Shared.Common.Database.DAO.Common -import Shared.Common.Model.Context.AppContext -import Shared.Common.Util.Logger - -entityName = "action_key" - -findActionKeys :: (AppContextC s sc m, FromField identity, FromField aType) => m [ActionKey identity aType] -findActionKeys = do - tenantUuid <- asks (.tenantUuid') - createFindEntitiesByFn entityName [tenantQueryUuid tenantUuid] - -findActionKeyByHash :: (AppContextC s sc m, FromField identity, FromField aType) => String -> m (ActionKey identity aType) -findActionKeyByHash hash = do - tenantUuid <- asks (.tenantUuid') - createFindEntityByFn entityName [tenantQueryUuid tenantUuid, ("hash", hash)] - -findActionKeyByHashAndType :: (AppContextC s sc m, FromField identity, FromField aType, Show aType) => String -> aType -> m (ActionKey identity aType) -findActionKeyByHashAndType hash aType = do - tenantUuid <- asks (.tenantUuid') - createFindEntityByFn entityName [tenantQueryUuid tenantUuid, ("hash", hash), ("type", show aType)] - -findActionKeyByIdentityAndType' :: (AppContextC s sc m, ToField identity, FromField identity, FromField aType, Show aType) => String -> aType -> m (Maybe (ActionKey identity aType)) -findActionKeyByIdentityAndType' identity aType = do - tenantUuid <- asks (.tenantUuid') - createFindEntityByFn' entityName [tenantQueryUuid tenantUuid, ("identity", identity), ("type", show aType)] - -findActionKeyByIdentityAndHash' - :: ( AppContextC s sc m - , FromField aType - , FromField identity - , ToField identity - ) - => String - -> String - -> m (Maybe (ActionKey identity aType)) -findActionKeyByIdentityAndHash' identity hash = do - tenantUuid <- asks (.tenantUuid') - createFindEntityByFn' entityName [tenantQueryUuid tenantUuid, ("identity", identity), ("hash", hash)] - -insertActionKey :: (AppContextC s sc m, ToField aType, ToField identity) => ActionKey identity aType -> m Int64 -insertActionKey = createInsertFn entityName - -deleteActionKeys :: AppContextC s sc m => m Int64 -deleteActionKeys = createDeleteEntitiesFn entityName - -deleteActionKeyByHash :: AppContextC s sc m => String -> m Int64 -deleteActionKeyByHash hash = do - tenantUuid <- asks (.tenantUuid') - createDeleteEntityByFn entityName [tenantQueryUuid tenantUuid, ("hash", hash)] - -deleteActionKeyByIdentity :: AppContextC s sc m => String -> m Int64 -deleteActionKeyByIdentity identity = do - tenantUuid <- asks (.tenantUuid') - createDeleteEntityByFn entityName [tenantQueryUuid tenantUuid, ("identity", identity)] - -deleteActionKeyByIdentityAndHash :: AppContextC s sc m => String -> String -> m Int64 -deleteActionKeyByIdentityAndHash identity hash = do - tenantUuid <- asks (.tenantUuid') - createDeleteEntityByFn entityName [tenantQueryUuid tenantUuid, ("identity", identity), ("hash", hash)] - -deleteActionKeyOlderThen :: AppContextC s sc m => UTCTime -> m Int64 -deleteActionKeyOlderThen date = do - let sql = fromString $ f' "DELETE FROM %s WHERE created_at < ? " [entityName] - let params = [toField date] - logQuery sql params - let action conn = execute conn sql params - runDB action diff --git a/shared-common/src/Shared/Common/Application.hs b/shared-common/src/Shared/Common/Application.hs index accb03806..1347f031a 100644 --- a/shared-common/src/Shared/Common/Application.hs +++ b/shared-common/src/Shared/Common/Application.hs @@ -7,6 +7,7 @@ import Data.Foldable (forM_) import System.Exit import System.IO +import Shared.Common.Bootstrap.AwsAppConfig import Shared.Common.Bootstrap.Config import Shared.Common.Bootstrap.DatabaseMigration import Shared.Common.Bootstrap.HttpClient @@ -32,12 +33,14 @@ runWebServerWithWorkers do hSetBuffering stdout LineBuffering sequence_ beforeLoadActions - serverConfig <- loadConfig serverConfigFile (getServerConfig validateServerConfig) + (configBytes, pollForChanges) <- resolveConfigBytes serverConfigFile + serverConfig <- loadConfigWith serverConfigFile configBytes (getServerConfig validateServerConfig) buildInfoConfig <- loadConfig buildInfoFile getBuildInfoConfig result <- runLogging serverConfig.logging.level $ do logInfo _CMP_ENVIRONMENT $ "set to " ++ serverConfig.general.environment shutdownFlag <- liftIO newEmptyMVar + _ <- liftIO . forkIO $ pollForChanges shutdownFlag dbPool <- connectPostgresDB serverConfig.logging serverConfig.database httpClientManager <- setupHttpClientManager serverConfig.logging s3Client <- setupS3Client serverConfig.s3 httpClientManager diff --git a/shared-common/src/Shared/Common/Bootstrap/AwsAppConfig.hs b/shared-common/src/Shared/Common/Bootstrap/AwsAppConfig.hs new file mode 100644 index 000000000..3e5d5e0cb --- /dev/null +++ b/shared-common/src/Shared/Common/Bootstrap/AwsAppConfig.hs @@ -0,0 +1,153 @@ +module Shared.Common.Bootstrap.AwsAppConfig ( + resolveConfigPath, + resolveConfigBytes, +) where + +import qualified Amazonka as AWS +import Amazonka.AppConfigData +import Amazonka.AppConfigData.GetLatestConfiguration +import Amazonka.AppConfigData.StartConfigurationSession +import Control.Concurrent (MVar, threadDelay, tryPutMVar) +import Control.Exception (SomeException, try) +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) +import qualified Data.Text as T +import Shared.Common.Util.String +import System.Environment (lookupEnv) +import System.Exit (die) +import System.IO (hClose, openTempFile) + +import Shared.Common.Integration.Aws.Common + +resolveConfigPath :: FilePath -> IO (FilePath, MVar () -> IO ()) +resolveConfigPath defaultPath = do + mResult <- fetchFromAppConfig defaultPath + case mResult of + Just (yamlBytes, profileIdentifier, poller) -> do + path <- writeTempYaml profileIdentifier yamlBytes + logInfo $ f' "configuration written to temp file: %s" [path] + return (path, poller) + Nothing -> do + logInfo $ f' "using local config file: %s" [defaultPath] + return (defaultPath, \_ -> return ()) + +resolveConfigBytes :: FilePath -> IO (ByteString, MVar () -> IO ()) +resolveConfigBytes defaultPath = do + mResult <- fetchFromAppConfig defaultPath + case mResult of + Just (yamlBytes, _, poller) -> do + logInfo "configuration loaded into memory (no temp file written)" + return (yamlBytes, poller) + Nothing -> do + mOverride <- lookupEnv "APPLICATION_CONFIG_PATH" + let path = fromMaybe defaultPath mOverride + when (isJust mOverride) $ logInfo $ f' "overriding the config path with '%s'" [path] + logInfo $ f' "using local config file: %s" [path] + bs <- BS.readFile path + return (bs, \_ -> return ()) + +-- --------------------------------------------------------------------------- +-- PRIVATE +-- --------------------------------------------------------------------------- +fetchFromAppConfig :: FilePath -> IO (Maybe (ByteString, String, MVar () -> IO ())) +fetchFromAppConfig defaultPath = do + mAppId <- lookupEnv "AWS_APP_CONFIG" + mAccessKeyId <- lookupEnv "AWS_ACCESS_KEY_ID" + mSecretAccessKey <- lookupEnv "AWS_SECRET_ACCESS_KEY" + mRegion <- lookupEnv "AWS_REGION" + case (mAppId, mAccessKeyId, mSecretAccessKey, mRegion) of + (Just appId, Just accessKeyId, Just secretAccessKey, Just region) -> do + let envIdentifier = "Default" + let profileIdentifier = replace "." "-" . last . splitOn "/" $ defaultPath + debug <- isDebugEnabled + logInfo $ + f' + "loading from AWS AppConfig (app=%s, env=%s, profile=%s, debug=%s)" + [appId, envIdentifier, profileIdentifier, show debug] + logInfo "starting AppConfig configuration session" + (yamlBytes, nextToken, intervalSec) <- fetchInitialConfig accessKeyId secretAccessKey region appId envIdentifier profileIdentifier + logInfo $ + f' + "initial configuration loaded (%s bytes); next poll in %ss; next token=%s" + [show (BS.length yamlBytes), show intervalSec, take 8 (T.unpack nextToken)] + return $ Just (yamlBytes, profileIdentifier, pollLoop debug accessKeyId secretAccessKey region nextToken intervalSec) + _ -> return Nothing + +fetchInitialConfig :: String -> String -> String -> String -> String -> String -> IO (ByteString, Text, Int) +fetchInitialConfig accessKeyId secretAccessKey region appId envId profileId = + runAwsRequest accessKeyId secretAccessKey region $ \env -> do + sessionResp <- AWS.send env $ newStartConfigurationSession (T.pack appId) (T.pack envId) (T.pack profileId) + token <- case sessionResp.initialConfigurationToken of + Just t -> return t + Nothing -> liftIO $ die "AppConfig StartConfigurationSession did not return an initial token" + configResp <- AWS.send env $ newGetLatestConfiguration token + bs <- case configResp.configuration of + Just (AWS.Sensitive b) -> return b + Nothing -> liftIO $ die "AppConfig GetLatestConfiguration returned empty configuration body" + nextToken <- case configResp.nextPollConfigurationToken of + Just t -> return t + Nothing -> liftIO $ die "AppConfig GetLatestConfiguration did not return a next-poll token" + let interval = fromMaybe 60 configResp.nextPollIntervalInSeconds + return (bs, nextToken, interval) + +pollLoop :: Bool -> String -> String -> String -> Text -> Int -> MVar () -> IO () +pollLoop debug accessKeyId secretAccessKey region initialToken initialInterval shutdownFlag = do + logInfo $ f' "starting poll loop (interval=%ss)" [show initialInterval] + loop initialToken initialInterval (0 :: Int) + where + loop token interval iter = do + threadDelay (interval * 1000000) + let iter' = iter + 1 + logDebug debug $ f' "poll #%s (token=%s)" [show iter', take 8 (T.unpack token)] + result <- + try $ + runAwsRequest accessKeyId secretAccessKey region $ \env -> + AWS.send env $ newGetLatestConfiguration token + case result of + Left (e :: SomeException) -> do + logInfo $ f' "poll #%s failed: %s — retrying after %ss" [show iter', show e, show interval] + loop token interval iter' + Right configResp -> do + let nextToken = fromMaybe token configResp.nextPollConfigurationToken + nextInterval = fromMaybe interval configResp.nextPollIntervalInSeconds + case configResp.configuration of + Just (AWS.Sensitive bs) | not (BS.null bs) -> do + logInfo $ + f' + "configuration changed at poll #%s (%s bytes) — triggering shutdown for restart" + [show iter', show (BS.length bs)] + _ <- tryPutMVar shutdownFlag () + return () + _ -> do + logDebug debug $ + f' + "poll #%s no change; next poll in %ss; next token=%s" + [show iter', show nextInterval, take 8 (T.unpack nextToken)] + loop nextToken nextInterval iter' + +-- --------------------------------------------------------------------------- +-- HELPERS +-- --------------------------------------------------------------------------- +writeTempYaml :: String -> ByteString -> IO FilePath +writeTempYaml profileIdentifier bs = do + (path, h) <- openTempFile "/tmp" (f' "%s-.yml" [profileIdentifier]) + BS.hPut h bs + hClose h + return path + +isDebugEnabled :: IO Bool +isDebugEnabled = do + m <- lookupEnv "AWS_APP_CONFIG_DEBUG" + return $ case m of + Just s | not (null s) -> True + _ -> False + +logInfo :: String -> IO () +logInfo msg = putStrLn $ f' "CONFIG: %s" [msg] + +logDebug :: Bool -> String -> IO () +logDebug debug msg = when debug $ putStrLn $ f' "CONFIG [debug]: %s" [msg] diff --git a/shared-common/src/Shared/Common/Bootstrap/Config.hs b/shared-common/src/Shared/Common/Bootstrap/Config.hs index fddee4502..a61151800 100644 --- a/shared-common/src/Shared/Common/Bootstrap/Config.hs +++ b/shared-common/src/Shared/Common/Bootstrap/Config.hs @@ -2,14 +2,16 @@ module Shared.Common.Bootstrap.Config where import System.Exit -loadConfig fileName loadFn = do - eitherConfig <- loadFn fileName +loadConfig fileName = loadConfigWith fileName fileName + +loadConfigWith label source loadFn = do + eitherConfig <- loadFn source case eitherConfig of Right config -> do - print ("Config '" ++ fileName ++ "' loaded") + print ("Config '" ++ label ++ "' loaded") return config Left error -> do print "Config load failed" - print ("Server can't load '" ++ fileName ++ "'. Maybe the file is missing or not well-formatted") + print ("Server can't load '" ++ label ++ "'. Maybe the file is missing or not well-formatted") print error exitFailure diff --git a/shared-common/src/Shared/Common/Integration/Aws/Common.hs b/shared-common/src/Shared/Common/Integration/Aws/Common.hs index f5470f758..ffed4efee 100644 --- a/shared-common/src/Shared/Common/Integration/Aws/Common.hs +++ b/shared-common/src/Shared/Common/Integration/Aws/Common.hs @@ -14,16 +14,24 @@ import qualified System.IO as IO import Shared.Common.Model.Config.ServerConfig import Shared.Common.Model.Context.AppContext -runAwsRequest :: AppContextC s sc m => (AWSAuth.Env -> ResourceT IO response) -> m response -runAwsRequest function = do +runAwsRequest :: String -> String -> String -> (AWSAuth.Env -> ResourceT IO response) -> IO response +runAwsRequest awsAccessKeyId awsSecretAccessKey awsRegion function = do + let accessKeyId = AWSAuth.AccessKey $ BS.pack awsAccessKeyId + let secretAccessKey = AWSAuth.SecretKey $ BS.pack awsSecretAccessKey + logger <- AWS.newLogger AWS.Trace IO.stdout + envWithoutRegion <- AWS.newEnv (return . AWSAuth.fromKeys accessKeyId secretAccessKey) + let env = envWithoutRegion {AWS.region = AWS.Region' (T.pack awsRegion)} + AWS.runResourceT (function env) + +runAwsRequestWithContext :: AppContextC s sc m => (AWSAuth.Env -> ResourceT IO response) -> m response +runAwsRequestWithContext function = do context <- ask - liftIO $ do - let accessKeyId = AWSAuth.AccessKey $ BS.pack context.serverConfig'.aws'.awsAccessKeyId - let secretAccessKey = AWSAuth.SecretKey $ BS.pack context.serverConfig'.aws'.awsSecretAccessKey - logger <- AWS.newLogger AWS.Trace IO.stdout - envWithoutRegion <- AWS.newEnv (return . AWSAuth.fromKeys accessKeyId secretAccessKey) - let env = envWithoutRegion {AWS.region = AWS.Region' (T.pack context.serverConfig'.aws'.awsRegion)} - AWS.runResourceT (function env) + liftIO $ + runAwsRequest + context.serverConfig'.aws'.awsAccessKeyId + context.serverConfig'.aws'.awsSecretAccessKey + context.serverConfig'.aws'.awsRegion + function utcTimeToAwsTime :: UTCTime -> Int64 utcTimeToAwsTime = floor . (1000 *) . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds diff --git a/shared-common/src/Shared/Common/Integration/Aws/Lambda.hs b/shared-common/src/Shared/Common/Integration/Aws/Lambda.hs index 1af3e3cbf..36d4cf267 100644 --- a/shared-common/src/Shared/Common/Integration/Aws/Lambda.hs +++ b/shared-common/src/Shared/Common/Integration/Aws/Lambda.hs @@ -22,6 +22,6 @@ invokeLambda functionArn payload = do , payload = payload } logInfoI _CMP_INTEGRATION (show request) - response <- runAwsRequest (`AWS.send` request) + response <- runAwsRequestWithContext (`AWS.send` request) logInfoI _CMP_INTEGRATION (show response) return $ response.statusCode == 200 diff --git a/shared-common/src/Shared/Common/Integration/Http/Common/HttpClientFactory.hs b/shared-common/src/Shared/Common/Integration/Http/Common/HttpClientFactory.hs index 9dd584b3d..5f643af32 100644 --- a/shared-common/src/Shared/Common/Integration/Http/Common/HttpClientFactory.hs +++ b/shared-common/src/Shared/Common/Integration/Http/Common/HttpClientFactory.hs @@ -36,13 +36,13 @@ createHttpClientManager serverConfig = let logHttpClient = serverConfig.httpClientDebug in newManager ( tlsManagerSettings - { managerModifyRequest = modifyRequest logHttpClient + { managerModifyRequest = modifyRequest , managerModifyResponse = modifyResponse logHttpClient } ) -modifyRequest :: Bool -> Request -> IO Request -modifyRequest logHttpClient request = do +modifyRequest :: Request -> IO Request +modifyRequest request = do let originalHeaders = requestHeaders request -- Filter out "User-Agent" headers (case-insensitive) and (re-)add our explicit "User-Agent" header, to ensure there's only one User-Agent header. -- Note: Reason for using case-insensitive search for header key(s) is because HTTP spec. states that header keys are case-insensitive. @@ -52,11 +52,14 @@ modifyRequest logHttpClient request = do { path = BS.pack . replace "//" "/" . BS.unpack . path $ request , requestHeaders = ("User-Agent", "wizard-http-client") : headersWithoutUA } - logRequest logHttpClient updatedRequest return updatedRequest +-- Logging happens here (and not in modifyRequest) because http-client invokes +-- managerModifyRequest multiple times per HTTP call (for header/method discovery +-- and on redirects); managerModifyResponse runs once per response. modifyResponse :: Bool -> Response BodyReader -> IO (Response BodyReader) modifyResponse logHttpClient response = do + logRequest logHttpClient (getOriginalRequest response) logResponse logHttpClient response return response diff --git a/shared-common/src/Shared/Common/Localization/Messages/Public.hs b/shared-common/src/Shared/Common/Localization/Messages/Public.hs index 110dca9fc..9f76ef72c 100644 --- a/shared-common/src/Shared/Common/Localization/Messages/Public.hs +++ b/shared-common/src/Shared/Common/Localization/Messages/Public.hs @@ -64,6 +64,9 @@ _ERROR_VALIDATION__FORBIDDEN action = LocaleRecord "error.validation.forbidden" _ERROR_SERVICE_COMMON__FEATURE_IS_DISABLED featureName = LocaleRecord "error.service.common.feature_is_disabled" "Feature '%s' is disabled" [featureName] +-- User Email Link +_ERROR_SERVICE_USER_EMAIL_LINK__EXPIRED = LocaleRecord "error.service.user_email_link.expired" "Link is expired" [] + -- Tenant _ERROR_SERVICE_TENANT__LIMIT_EXCEEDED name maxLimit actualLimit = LocaleRecord diff --git a/shared-common/src/Shared/Common/Model/Config/ServerConfig.hs b/shared-common/src/Shared/Common/Model/Config/ServerConfig.hs index 08bf3db7a..f8e392ce5 100644 --- a/shared-common/src/Shared/Common/Model/Config/ServerConfig.hs +++ b/shared-common/src/Shared/Common/Model/Config/ServerConfig.hs @@ -43,11 +43,6 @@ data ServerConfigSentry = ServerConfigSentry } deriving (Generic, Show) -data ServerConfigJwt = ServerConfigJwt - { expiration :: Integer - } - deriving (Generic, Show) - data ServerConfigAnalyticalMails = ServerConfigAnalyticalMails { enabled :: Bool , email :: String @@ -70,11 +65,6 @@ data ServerConfigCloud = ServerConfigCloud } deriving (Generic, Show) -data ServerConfigPlan = ServerConfigPlan - { recomputeJob :: ServerConfigCronWorker - } - deriving (Generic, Show) - data ServerConfigPersistentCommand = ServerConfigPersistentCommand { lambdaFunctions :: [ServerConfigPersistentCommandLambda] , listenerJob :: ServerConfigPersistentCommandListenerJob diff --git a/shared-common/src/Shared/Common/Model/Config/ServerConfigDM.hs b/shared-common/src/Shared/Common/Model/Config/ServerConfigDM.hs index 950ac5253..dac1d4b63 100644 --- a/shared-common/src/Shared/Common/Model/Config/ServerConfigDM.hs +++ b/shared-common/src/Shared/Common/Model/Config/ServerConfigDM.hs @@ -45,9 +45,6 @@ defaultAws = defaultSentry :: ServerConfigSentry defaultSentry = ServerConfigSentry {enabled = False, dsn = ""} -defaultJwt :: ServerConfigJwt -defaultJwt = ServerConfigJwt {expiration = 14 * 24} - defaultAnalyticalMails :: ServerConfigAnalyticalMails defaultAnalyticalMails = ServerConfigAnalyticalMails {enabled = False, email = ""} @@ -69,13 +66,6 @@ defaultCloud = , signalBridgeUrl = Nothing } -defaultPlan :: ServerConfigPlan -defaultPlan = ServerConfigPlan {recomputeJob = defaultPlanRecomputeJob} - -defaultPlanRecomputeJob :: ServerConfigCronWorker -defaultPlanRecomputeJob = - ServerConfigCronWorker {enabled = False, cron = "0 * * * *"} - defaultPersistentCommand :: ServerConfigPersistentCommand defaultPersistentCommand = ServerConfigPersistentCommand diff --git a/shared-common/src/Shared/Common/Model/Config/ServerConfigIM.hs b/shared-common/src/Shared/Common/Model/Config/ServerConfigIM.hs index 204407865..772c281a9 100644 --- a/shared-common/src/Shared/Common/Model/Config/ServerConfigIM.hs +++ b/shared-common/src/Shared/Common/Model/Config/ServerConfigIM.hs @@ -59,13 +59,6 @@ instance FromEnv ServerConfigSentry where , \c -> applyStringEnvVariable "SENTRY_DSN" c.dsn (\x -> c {dsn = x}) ] -instance FromEnv ServerConfigJwt where - applyEnv serverConfig = - applyEnvVariables - serverConfig - [ \c -> applyEnvVariable "JWT_EXPIRATION" c.expiration (\x -> c {expiration = x}) - ] - instance FromEnv ServerConfigAnalyticalMails where applyEnv serverConfig = applyEnvVariables @@ -93,14 +86,6 @@ instance FromEnv ServerConfigCloud where , \c -> applyEnvVariable "CLOUD_SIGNAL_BRIDGE_URL" c.signalBridgeUrl (\x -> c {signalBridgeUrl = x}) ] -instance FromEnv ServerConfigPlan where - applyEnv serverConfig = - applyEnvVariables - serverConfig - [ \c -> applyEnvVariable "PLAN_RECOMPUTE_JOB_ENABLED" c.recomputeJob.enabled (\x -> c {recomputeJob = c.recomputeJob {enabled = x}} :: ServerConfigPlan) - , \c -> applyStringEnvVariable "PLAN_RECOMPUTE_JOB_CRON" c.recomputeJob.cron (\x -> c {recomputeJob = c.recomputeJob {cron = x}} :: ServerConfigPlan) - ] - instance FromEnv ServerConfigPersistentCommand where applyEnv serverConfig = applyEnvVariables diff --git a/shared-common/src/Shared/Common/Model/Config/ServerConfigJM.hs b/shared-common/src/Shared/Common/Model/Config/ServerConfigJM.hs index a2cb78f4a..ad8308bec 100644 --- a/shared-common/src/Shared/Common/Model/Config/ServerConfigJM.hs +++ b/shared-common/src/Shared/Common/Model/Config/ServerConfigJM.hs @@ -52,12 +52,6 @@ instance FromJSON ServerConfigSentry where return ServerConfigSentry {..} parseJSON _ = mzero -instance FromJSON ServerConfigJwt where - parseJSON (Object o) = do - expiration <- o .:? "expiration" .!= defaultJwt.expiration - return ServerConfigJwt {..} - parseJSON _ = mzero - instance FromJSON ServerConfigAnalyticalMails where parseJSON (Object o) = do enabled <- o .:? "enabled" .!= defaultAnalyticalMails.enabled @@ -92,12 +86,6 @@ instance FromJSON ServerConfigCloud where return ServerConfigCloud {..} parseJSON _ = mzero -instance FromJSON ServerConfigPlan where - parseJSON (Object o) = do - recomputeJob <- o .:? "recomputeJob" .!= defaultPlan.recomputeJob - return ServerConfigPlan {..} - parseJSON _ = mzero - instance FromJSON ServerConfigPersistentCommand where parseJSON (Object o) = do lambdaFunctions <- o .:? "lambdaFunctions" .!= [] diff --git a/shared-common/src/Shared/Common/Service/Config/Server/ServerConfigService.hs b/shared-common/src/Shared/Common/Service/Config/Server/ServerConfigService.hs index 6d680e357..45701bb5f 100644 --- a/shared-common/src/Shared/Common/Service/Config/Server/ServerConfigService.hs +++ b/shared-common/src/Shared/Common/Service/Config/Server/ServerConfigService.hs @@ -1,22 +1,15 @@ module Shared.Common.Service.Config.Server.ServerConfigService where -import Control.Monad (when) -import Control.Monad.Reader (liftIO) import Data.Aeson -import Data.Maybe (fromJust, fromMaybe, isJust) -import Data.Yaml (decodeFileEither) -import System.Environment (lookupEnv) +import Data.ByteString (ByteString) +import Data.Yaml (decodeEither') import Shared.Common.Model.Config.ServerConfigIM import Shared.Common.Model.Error.Error -getServerConfig :: (FromJSON serverConfig, FromEnv serverConfig) => (serverConfig -> Either AppError serverConfig) -> String -> IO (Either AppError serverConfig) -getServerConfig validateServerConfig fileNameBase = do - mFileNameEnv <- liftIO $ lookupEnv "APPLICATION_CONFIG_PATH" - when (isJust mFileNameEnv) (putStrLn $ "CONFIG: overriding the config path with '" ++ fromJust mFileNameEnv ++ "'") - let fileName = fromMaybe fileNameBase mFileNameEnv - eConfig <- decodeFileEither fileName - case eConfig of +getServerConfig :: (FromJSON serverConfig, FromEnv serverConfig) => (serverConfig -> Either AppError serverConfig) -> ByteString -> IO (Either AppError serverConfig) +getServerConfig validateServerConfig bs = + case decodeEither' bs of Right config -> do updatedConfig <- applyEnv config return . validateServerConfig $ updatedConfig diff --git a/shared-common/src/Shared/DocumentTemplate/Constant/DocumentTemplate.hs b/shared-common/src/Shared/DocumentTemplate/Constant/DocumentTemplate.hs index 361ff5893..22fb1ecd2 100644 --- a/shared-common/src/Shared/DocumentTemplate/Constant/DocumentTemplate.hs +++ b/shared-common/src/Shared/DocumentTemplate/Constant/DocumentTemplate.hs @@ -3,7 +3,7 @@ module Shared.DocumentTemplate.Constant.DocumentTemplate where import Shared.Common.Model.Common.SemVer2Tuple documentTemplateMetamodelVersion :: SemVer2Tuple -documentTemplateMetamodelVersion = SemVer2Tuple 18 0 +documentTemplateMetamodelVersion = SemVer2Tuple 18 1 isDocumentTemplateSupported :: SemVer2Tuple -> Bool isDocumentTemplateSupported metamodelVersion diff --git a/shared-common/src/Shared/OpenId/Localization/Messages/Public.hs b/shared-common/src/Shared/OpenId/Localization/Messages/Public.hs index c3e2f739c..402c651f3 100644 --- a/shared-common/src/Shared/OpenId/Localization/Messages/Public.hs +++ b/shared-common/src/Shared/OpenId/Localization/Messages/Public.hs @@ -11,6 +11,3 @@ _ERROR_VALIDATION__OPENID_WRONG_RESPONSE error = _ERROR_VALIDATION__OPENID_CODE_ABSENCE = LocaleRecord "error.validation.openid_code_absence" "Auth Code is not provided" [] - -_ERROR_VALIDATION__OPENID_PROFILE_INFO_ABSENCE = - LocaleRecord "error.validation.openid_profile_info_absence" "Profile Information from OpenID service is missing" [] diff --git a/shared-common/src/Shared/OpenId/Service/OpenId/Client/Flow/OpenIdClientFlowUtil.hs b/shared-common/src/Shared/OpenId/Service/OpenId/Client/Flow/OpenIdClientFlowUtil.hs index f096276d8..38d59d1df 100644 --- a/shared-common/src/Shared/OpenId/Service/OpenId/Client/Flow/OpenIdClientFlowUtil.hs +++ b/shared-common/src/Shared/OpenId/Service/OpenId/Client/Flow/OpenIdClientFlowUtil.hs @@ -1,6 +1,5 @@ module Shared.OpenId.Service.OpenId.Client.Flow.OpenIdClientFlowUtil where -import Control.Monad.Except (throwError) import qualified Data.Aeson as A import qualified Data.Aeson.KeyMap as KM import Data.Char (toLower) @@ -11,11 +10,12 @@ import qualified Web.OIDC.Client as O import qualified Web.OIDC.Client.Tokens as OT import Shared.Common.Model.Context.AppContext -import Shared.Common.Model.Error.Error import Shared.Common.Util.Maybe (concatMaybe) -import Shared.OpenId.Localization.Messages.Public -parseIdToken :: AppContextC s sc m => OT.IdTokenClaims A.Value -> m (String, String, String, Maybe String, Maybe U.UUID) +parseIdToken + :: AppContextC s sc m + => OT.IdTokenClaims A.Value + -> m (Maybe String, Maybe String, Maybe String, Maybe String, Maybe U.UUID) parseIdToken idToken = do let claims = O.otherClaims idToken let mEmail = fmap (fmap toLower) . getClaim "email" $ claims @@ -23,9 +23,7 @@ parseIdToken idToken = do let mLastName = getClaim "family_name" claims let mPicture = getClaim "picture" claims let mUserUuid = concatMaybe . fmap U.fromString . getClaim "user_uuid" $ claims - case (mEmail, mFirstName, mLastName) of - (Just email, Just firstName, Just lastName) -> return (email, firstName, lastName, mPicture, mUserUuid) - _ -> throwError . UserError $ _ERROR_VALIDATION__OPENID_PROFILE_INFO_ABSENCE + return (mEmail, mFirstName, mLastName, mPicture, mUserUuid) getClaim :: String -> A.Value -> Maybe String getClaim key (A.Object obj) = diff --git a/shared-common/src/Shared/PersistentCommand/Database/DAO/PersistentCommand/PersistentCommandDAO.hs b/shared-common/src/Shared/PersistentCommand/Database/DAO/PersistentCommand/PersistentCommandDAO.hs index ebc2dcd01..8f2bf28ab 100644 --- a/shared-common/src/Shared/PersistentCommand/Database/DAO/PersistentCommand/PersistentCommandDAO.hs +++ b/shared-common/src/Shared/PersistentCommand/Database/DAO/PersistentCommand/PersistentCommandDAO.hs @@ -17,7 +17,7 @@ import Shared.Common.Integration.Aws.Lambda import Shared.Common.Model.Config.ServerConfig import Shared.Common.Model.Context.AppContext import Shared.Common.Util.Logger -import Shared.Common.Util.String (f'', trim) +import Shared.Common.Util.String (trim) import Shared.PersistentCommand.Database.Mapping.PersistentCommand.LambdaInvocationResult () import Shared.PersistentCommand.Database.Mapping.PersistentCommand.PersistentCommand () import Shared.PersistentCommand.Database.Mapping.PersistentCommand.PersistentCommandSimple () @@ -33,34 +33,18 @@ findPersistentCommands :: (AppContextC s sc m, FromField identity) => m [Persist findPersistentCommands = createFindEntitiesFn entityName findPersistentCommandsForRetryByStates :: (AppContextC s sc m, FromField identity) => m [PersistentCommandSimple identity] -findPersistentCommandsForRetryByStates = findPersistentCommandsByStates True [] - -findPersistentCommandsForLambdaByStates :: (AppContextC s sc m, FromField identity) => [String] -> m [PersistentCommandSimple identity] -findPersistentCommandsForLambdaByStates = findPersistentCommandsByStates False - -findPersistentCommandsByStates :: (AppContextC s sc m, FromField identity) => Bool -> [String] -> m [PersistentCommandSimple identity] -findPersistentCommandsByStates internal components = do - let componentCondition = - case components of - [] -> "" - _ -> f' "AND component IN (%s) " [generateQuestionMarks components] +findPersistentCommandsForRetryByStates = do let sql = - fromString $ - f'' - "SELECT uuid, destination, component, tenant_uuid, created_by \ - \FROM persistent_command \ - \WHERE (state = 'NewPersistentCommandState' \ - \ OR (state = 'ErrorPersistentCommandState' AND attempts < max_attempts AND updated_at < (now() - (2 ^ attempts - 1) * INTERVAL '1 min'))) \ - \ AND internal = ${internal} ${componentCondition} \ - \ORDER BY created_at \ - \LIMIT 5 \ - \FOR UPDATE" - [ ("internal", show internal) - , ("componentCondition", componentCondition) - ] - let params = components - logQuery sql params - let action conn = query conn sql params + "SELECT uuid, destination, component, tenant_uuid, created_by \ + \FROM persistent_command \ + \WHERE (state = 'NewPersistentCommandState' \ + \ OR (state = 'ErrorPersistentCommandState' AND attempts < max_attempts AND updated_at < (now() - (2 ^ attempts - 1) * INTERVAL '1 min'))) \ + \ AND internal = true \ + \ORDER BY created_at \ + \LIMIT 5 \ + \FOR UPDATE" + logInfoI _CMP_DATABASE (trim sql) + let action conn = query_ conn (fromString sql) runDB action findPersistentCommandByUuid :: (AppContextC s sc m, FromField identity) => U.UUID -> m (PersistentCommand identity) diff --git a/shared-common/src/Shared/PersistentCommand/Service/PersistentCommand/PersistentCommandService.hs b/shared-common/src/Shared/PersistentCommand/Service/PersistentCommand/PersistentCommandService.hs index ecea56574..f482357e3 100644 --- a/shared-common/src/Shared/PersistentCommand/Service/PersistentCommand/PersistentCommandService.hs +++ b/shared-common/src/Shared/PersistentCommand/Service/PersistentCommand/PersistentCommandService.hs @@ -1,12 +1,11 @@ module Shared.PersistentCommand.Service.PersistentCommand.PersistentCommandService where import qualified Control.Exception.Base as E -import Control.Monad (forever, unless, void, when) +import Control.Monad (forever, unless, when) import Control.Monad.Reader (ask, liftIO) import Data.Aeson (Value (..), toJSON) import Data.Foldable (traverse_) import qualified Data.HashMap.Strict as HashMap -import qualified Data.List as L import Data.Maybe (fromMaybe) import qualified Data.Text as T import Data.Time @@ -144,20 +143,6 @@ runPersistentCommandChannelListener runAppContextWithAppContext updateContext cr _ <- getChannelNotification runPersistentCommands runAppContextWithAppContext updateContext createPersistentCommand execute -retryPersistentCommandsForLambda :: AppContextC s sc m => m () -retryPersistentCommandsForLambda = do - context <- ask - let components = fmap (\lf -> lf.component) context.serverConfig'.persistentCommand'.lambdaFunctions - persistentCommands <- findPersistentCommandsForLambdaByStates components - traverse_ retryPersistentCommandForLambda persistentCommands - -retryPersistentCommandForLambda :: (Show identity, FromField identity, ToField identity, AppContextC s sc m) => PersistentCommandSimple identity -> m () -retryPersistentCommandForLambda command = do - context <- ask - case L.find (\lf -> lf.component == command.component) context.serverConfig'.persistentCommand'.lambdaFunctions of - Just lf -> void $ invokeLambdaFunction command lf - Nothing -> logWarnI _CMP_DATABASE (f' "No lambda function found for persistent command '%s'" [U.toString command.uuid]) - -- -------------------------------- -- PRIVATE -- -------------------------------- diff --git a/shared-common/src/Shared/UserEmailLink/Api/Resource/UserEmailLink/UserEmailLinkDTO.hs b/shared-common/src/Shared/UserEmailLink/Api/Resource/UserEmailLink/UserEmailLinkDTO.hs new file mode 100644 index 000000000..c2a5eeee3 --- /dev/null +++ b/shared-common/src/Shared/UserEmailLink/Api/Resource/UserEmailLink/UserEmailLinkDTO.hs @@ -0,0 +1,9 @@ +module Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkDTO where + +import GHC.Generics + +data UserEmailLinkDTO aType = UserEmailLinkDTO + { aType :: aType + , email :: String + } + deriving (Show, Eq, Generic) diff --git a/shared-common/src/Shared/UserEmailLink/Api/Resource/UserEmailLink/UserEmailLinkJM.hs b/shared-common/src/Shared/UserEmailLink/Api/Resource/UserEmailLink/UserEmailLinkJM.hs new file mode 100644 index 000000000..bfc20f821 --- /dev/null +++ b/shared-common/src/Shared/UserEmailLink/Api/Resource/UserEmailLink/UserEmailLinkJM.hs @@ -0,0 +1,12 @@ +module Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkJM where + +import Data.Aeson + +import Shared.Common.Util.Aeson +import Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkDTO + +instance FromJSON aType => FromJSON (UserEmailLinkDTO aType) where + parseJSON = genericParseJSON jsonOptions + +instance ToJSON aType => ToJSON (UserEmailLinkDTO aType) where + toJSON = genericToJSON jsonOptions diff --git a/shared-common/src/Shared/UserEmailLink/Database/DAO/UserEmailLink/UserEmailLinkDAO.hs b/shared-common/src/Shared/UserEmailLink/Database/DAO/UserEmailLink/UserEmailLinkDAO.hs new file mode 100644 index 000000000..51008bb63 --- /dev/null +++ b/shared-common/src/Shared/UserEmailLink/Database/DAO/UserEmailLink/UserEmailLinkDAO.hs @@ -0,0 +1,79 @@ +module Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO where + +import Control.Monad.Reader (asks) +import Data.String +import Data.Time +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.ToField +import GHC.Int + +import Shared.Common.Database.DAO.Common +import Shared.Common.Model.Context.AppContext +import Shared.Common.Util.Logger +import Shared.UserEmailLink.Database.Mapping.UserEmailLink.UserEmailLink () +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink + +entityName = "user_email_link" + +findUserEmailLinks :: (AppContextC s sc m, FromField identity, FromField aType) => m [UserEmailLink identity aType] +findUserEmailLinks = do + tenantUuid <- asks (.tenantUuid') + createFindEntitiesByFn entityName [tenantQueryUuid tenantUuid] + +findUserEmailLinkByHash :: (AppContextC s sc m, FromField identity, FromField aType) => String -> m (UserEmailLink identity aType) +findUserEmailLinkByHash hash = do + tenantUuid <- asks (.tenantUuid') + createFindEntityByFn entityName [tenantQueryUuid tenantUuid, ("hash", hash)] + +findUserEmailLinkByHashAndType :: (AppContextC s sc m, FromField identity, FromField aType, Show aType) => String -> aType -> m (UserEmailLink identity aType) +findUserEmailLinkByHashAndType hash aType = do + tenantUuid <- asks (.tenantUuid') + createFindEntityByFn entityName [tenantQueryUuid tenantUuid, ("hash", hash), ("type", show aType)] + +findUserEmailLinkByIdentityAndType' :: (AppContextC s sc m, ToField identity, FromField identity, FromField aType, Show aType) => String -> aType -> m (Maybe (UserEmailLink identity aType)) +findUserEmailLinkByIdentityAndType' identity aType = do + tenantUuid <- asks (.tenantUuid') + createFindEntityByFn' entityName [tenantQueryUuid tenantUuid, ("identity", identity), ("type", show aType)] + +findUserEmailLinkByIdentityAndHash' + :: ( AppContextC s sc m + , FromField aType + , FromField identity + , ToField identity + ) + => String + -> String + -> m (Maybe (UserEmailLink identity aType)) +findUserEmailLinkByIdentityAndHash' identity hash = do + tenantUuid <- asks (.tenantUuid') + createFindEntityByFn' entityName [tenantQueryUuid tenantUuid, ("identity", identity), ("hash", hash)] + +insertUserEmailLink :: (AppContextC s sc m, ToField aType, ToField identity) => UserEmailLink identity aType -> m Int64 +insertUserEmailLink = createInsertFn entityName + +deleteUserEmailLinks :: AppContextC s sc m => m Int64 +deleteUserEmailLinks = createDeleteEntitiesFn entityName + +deleteUserEmailLinkByHash :: AppContextC s sc m => String -> m Int64 +deleteUserEmailLinkByHash hash = do + tenantUuid <- asks (.tenantUuid') + createDeleteEntityByFn entityName [tenantQueryUuid tenantUuid, ("hash", hash)] + +deleteUserEmailLinkByIdentity :: AppContextC s sc m => String -> m Int64 +deleteUserEmailLinkByIdentity identity = do + tenantUuid <- asks (.tenantUuid') + createDeleteEntityByFn entityName [tenantQueryUuid tenantUuid, ("identity", identity)] + +deleteUserEmailLinkByIdentityAndHash :: AppContextC s sc m => String -> String -> m Int64 +deleteUserEmailLinkByIdentityAndHash identity hash = do + tenantUuid <- asks (.tenantUuid') + createDeleteEntityByFn entityName [tenantQueryUuid tenantUuid, ("identity", identity), ("hash", hash)] + +deleteUserEmailLinkOlderThen :: AppContextC s sc m => UTCTime -> m Int64 +deleteUserEmailLinkOlderThen date = do + let sql = fromString $ f' "DELETE FROM %s WHERE created_at < ? " [entityName] + let params = [toField date] + logQuery sql params + let action conn = execute conn sql params + runDB action diff --git a/shared-common/src/Shared/ActionKey/Database/Mapping/ActionKey/ActionKey.hs b/shared-common/src/Shared/UserEmailLink/Database/Mapping/UserEmailLink/UserEmailLink.hs similarity index 55% rename from shared-common/src/Shared/ActionKey/Database/Mapping/ActionKey/ActionKey.hs rename to shared-common/src/Shared/UserEmailLink/Database/Mapping/UserEmailLink/UserEmailLink.hs index 0bdabf2e8..eb453b9a3 100644 --- a/shared-common/src/Shared/ActionKey/Database/Mapping/ActionKey/ActionKey.hs +++ b/shared-common/src/Shared/UserEmailLink/Database/Mapping/UserEmailLink/UserEmailLink.hs @@ -1,4 +1,4 @@ -module Shared.ActionKey.Database.Mapping.ActionKey.ActionKey where +module Shared.UserEmailLink.Database.Mapping.UserEmailLink.UserEmailLink where import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.FromField @@ -6,10 +6,10 @@ import Database.PostgreSQL.Simple.FromRow import Database.PostgreSQL.Simple.ToField import Database.PostgreSQL.Simple.ToRow -import Shared.ActionKey.Model.ActionKey.ActionKey +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink -instance (ToField aType, ToField identity) => ToRow (ActionKey identity aType) where - toRow ActionKey {..} = +instance (ToField aType, ToField identity) => ToRow (UserEmailLink identity aType) where + toRow UserEmailLink {..} = [ toField uuid , toField identity , toField aType @@ -18,7 +18,7 @@ instance (ToField aType, ToField identity) => ToRow (ActionKey identity aType) w , toField tenantUuid ] -instance (FromField aType, FromField identity) => FromRow (ActionKey identity aType) where +instance (FromField aType, FromField identity) => FromRow (UserEmailLink identity aType) where fromRow = do uuid <- field identity <- field @@ -26,4 +26,4 @@ instance (FromField aType, FromField identity) => FromRow (ActionKey identity aT hash <- field createdAt <- field tenantUuid <- field - return $ ActionKey {..} + return $ UserEmailLink {..} diff --git a/shared-common/src/Shared/ActionKey/Model/ActionKey/ActionKey.hs b/shared-common/src/Shared/UserEmailLink/Model/UserEmailLink/UserEmailLink.hs similarity index 66% rename from shared-common/src/Shared/ActionKey/Model/ActionKey/ActionKey.hs rename to shared-common/src/Shared/UserEmailLink/Model/UserEmailLink/UserEmailLink.hs index ed036c68c..441abb59b 100644 --- a/shared-common/src/Shared/ActionKey/Model/ActionKey/ActionKey.hs +++ b/shared-common/src/Shared/UserEmailLink/Model/UserEmailLink/UserEmailLink.hs @@ -1,10 +1,10 @@ -module Shared.ActionKey.Model.ActionKey.ActionKey where +module Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink where import Data.Time import qualified Data.UUID as U import GHC.Generics -data ActionKey identity aType = ActionKey +data UserEmailLink identity aType = UserEmailLink { uuid :: U.UUID , identity :: identity , aType :: aType @@ -14,7 +14,7 @@ data ActionKey identity aType = ActionKey } deriving (Show, Generic) -instance (Eq identity, Eq aType) => Eq (ActionKey identity aType) where +instance (Eq identity, Eq aType) => Eq (UserEmailLink identity aType) where a == b = uuid a == uuid b && identity a == identity b diff --git a/shared-common/src/Shared/ActionKey/Service/ActionKey/ActionKeyService.hs b/shared-common/src/Shared/UserEmailLink/Service/UserEmailLink/UserEmailLinkService.hs similarity index 57% rename from shared-common/src/Shared/ActionKey/Service/ActionKey/ActionKeyService.hs rename to shared-common/src/Shared/UserEmailLink/Service/UserEmailLink/UserEmailLinkService.hs index 472303ab4..25605cbe8 100644 --- a/shared-common/src/Shared/ActionKey/Service/ActionKey/ActionKeyService.hs +++ b/shared-common/src/Shared/UserEmailLink/Service/UserEmailLink/UserEmailLinkService.hs @@ -1,41 +1,41 @@ -module Shared.ActionKey.Service.ActionKey.ActionKeyService where +module Shared.UserEmailLink.Service.UserEmailLink.UserEmailLinkService where import Control.Monad.Reader (liftIO) import Data.Time import qualified Data.UUID as U import Database.PostgreSQL.Simple.ToField -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO -import Shared.ActionKey.Model.ActionKey.ActionKey import Shared.Common.Database.DAO.Common import Shared.Common.Model.Context.AppContext import Shared.Common.Util.Date import Shared.Common.Util.Logger import Shared.Common.Util.Uuid +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink -createActionKey +createUserEmailLink :: (AppContextC s sc m, ToField aType, ToField identity) => identity -> aType -> U.UUID - -> m (ActionKey identity aType) -createActionKey identity actionType tenantUuid = do + -> m (UserEmailLink identity aType) +createUserEmailLink identity actionType tenantUuid = do hash <- liftIO generateUuid - createActionKeyWithHash identity actionType tenantUuid (U.toString hash) + createUserEmailLinkWithHash identity actionType tenantUuid (U.toString hash) -createActionKeyWithHash +createUserEmailLinkWithHash :: (AppContextC s sc m, ToField aType, ToField identity) => identity -> aType -> U.UUID -> String - -> m (ActionKey identity aType) -createActionKeyWithHash identity actionType tenantUuid hash = + -> m (UserEmailLink identity aType) +createUserEmailLinkWithHash identity actionType tenantUuid hash = runInTransaction logInfoI logWarnI $ do uuid <- liftIO generateUuid now <- liftIO getCurrentTime - let actionKey = - ActionKey + let userEmailLink = + UserEmailLink { uuid = uuid , identity = identity , aType = actionType @@ -43,13 +43,13 @@ createActionKeyWithHash identity actionType tenantUuid hash = , tenantUuid = tenantUuid , createdAt = now } - insertActionKey actionKey - return actionKey + insertUserEmailLink userEmailLink + return userEmailLink -cleanActionKeys :: AppContextC s sc m => m () -cleanActionKeys = do +cleanUserEmailLinks :: AppContextC s sc m => m () +cleanUserEmailLinks = do now <- liftIO getCurrentTime let timeDelta = realToFrac . toInteger $ nominalDayInSeconds * (-1) let dayBefore = addUTCTime timeDelta now - deleteActionKeyOlderThen dayBefore + deleteUserEmailLinkOlderThen dayBefore return () diff --git a/stack.yaml b/stack.yaml index 48c5c0ae3..ac65fcba0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -29,6 +29,7 @@ extra-deps: subdirs: - lib/amazonka - lib/amazonka-core + - lib/services/amazonka-appconfigdata - lib/services/amazonka-lambda - lib/services/amazonka-sso - lib/services/amazonka-sts diff --git a/stack.yaml.lock b/stack.yaml.lock index aa039343d..3d38f0b22 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -107,6 +107,19 @@ packages: original: subdir: lib/amazonka-core url: https://github.com/brendanhay/amazonka/archive/f3a7fca02fdbb832cc348e991983b1465225d50c.tar.gz +- completed: + name: amazonka-appconfigdata + pantry-tree: + sha256: 102aa7982f235db3079f09c29f92feeb5be0d74499ad9b499f18b5b765fa6cf1 + size: 1320 + sha256: 06f5e8430080e5a46e4489e12978725f4b01cfb896450a12a01bcde88168c7f2 + size: 34855734 + subdir: lib/services/amazonka-appconfigdata + url: https://github.com/brendanhay/amazonka/archive/f3a7fca02fdbb832cc348e991983b1465225d50c.tar.gz + version: '2.0' + original: + subdir: lib/services/amazonka-appconfigdata + url: https://github.com/brendanhay/amazonka/archive/f3a7fca02fdbb832cc348e991983b1465225d50c.tar.gz - completed: name: amazonka-lambda pantry-tree: diff --git a/wizard-public/package.yaml b/wizard-public/package.yaml index 643af20ce..07a2ca5a5 100644 --- a/wizard-public/package.yaml +++ b/wizard-public/package.yaml @@ -1,5 +1,5 @@ name: wizard-public -version: '4.30.0' +version: '4.31.0' synopsis: Wizard Public description: Wizard Public category: Web diff --git a/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientChangeDTO.hs b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientChangeDTO.hs new file mode 100644 index 000000000..23b5bfc9c --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientChangeDTO.hs @@ -0,0 +1,19 @@ +module WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeDTO where + +import GHC.Generics + +import Shared.OpenId.Model.OpenId.OpenIdClientParameter +import Shared.OpenId.Model.OpenId.OpenIdClientStyle + +data OpenIdClientChangeDTO = OpenIdClientChangeDTO + { name :: String + , url :: String + , clientId :: String + , clientSecret :: String + , parameters :: [OpenIdClientParameter] + , style :: OpenIdClientStyle + , registrationEnabled :: Bool + , scopeProfile :: Bool + , scopeEmail :: Bool + } + deriving (Generic, Show) diff --git a/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientChangeJM.hs b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientChangeJM.hs new file mode 100644 index 000000000..a4da572ad --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientChangeJM.hs @@ -0,0 +1,14 @@ +module WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeJM where + +import Data.Aeson + +import Shared.Common.Util.Aeson +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientParameterJM () +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientStyleJM () +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeDTO + +instance FromJSON OpenIdClientChangeDTO where + parseJSON = genericParseJSON jsonOptions + +instance ToJSON OpenIdClientChangeDTO where + toJSON = genericToJSON jsonOptions diff --git a/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientChangeSM.hs b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientChangeSM.hs new file mode 100644 index 000000000..13c69c054 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientChangeSM.hs @@ -0,0 +1,13 @@ +module WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeSM where + +import Data.Swagger + +import Shared.Common.Util.Swagger +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientParameterSM () +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientStyleSM () +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeDTO +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeJM () +import WizardLib.Public.Database.Migration.Development.OpenId.Data.OpenIdClients + +instance ToSchema OpenIdClientChangeDTO where + declareNamedSchema = toSwagger defaultOpenIdClientChangeDto diff --git a/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientDetailDTO.hs b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientDetailDTO.hs new file mode 100644 index 000000000..976ca03a0 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientDetailDTO.hs @@ -0,0 +1,25 @@ +module WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailDTO where + +import Data.Time +import qualified Data.UUID as U +import GHC.Generics + +import Shared.OpenId.Model.OpenId.OpenIdClientParameter +import Shared.OpenId.Model.OpenId.OpenIdClientStyle + +data OpenIdClientDetailDTO = OpenIdClientDetailDTO + { uuid :: U.UUID + , name :: String + , url :: String + , clientId :: String + , clientSecret :: String + , parameters :: [OpenIdClientParameter] + , style :: OpenIdClientStyle + , registrationEnabled :: Bool + , scopeProfile :: Bool + , scopeEmail :: Bool + , tenantUuid :: U.UUID + , createdAt :: UTCTime + , updatedAt :: UTCTime + } + deriving (Generic, Show) diff --git a/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientDetailJM.hs b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientDetailJM.hs new file mode 100644 index 000000000..a8dd0fd57 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientDetailJM.hs @@ -0,0 +1,14 @@ +module WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailJM where + +import Data.Aeson + +import Shared.Common.Util.Aeson +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientParameterJM () +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientStyleJM () +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailDTO + +instance FromJSON OpenIdClientDetailDTO where + parseJSON = genericParseJSON jsonOptions + +instance ToJSON OpenIdClientDetailDTO where + toJSON = genericToJSON jsonOptions diff --git a/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientDetailSM.hs b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientDetailSM.hs new file mode 100644 index 000000000..2d38b8460 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientDetailSM.hs @@ -0,0 +1,13 @@ +module WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailSM where + +import Data.Swagger + +import Shared.Common.Util.Swagger +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientParameterSM () +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientStyleSM () +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailDTO +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailJM () +import WizardLib.Public.Database.Migration.Development.OpenId.Data.OpenIdClients + +instance ToSchema OpenIdClientDetailDTO where + declareNamedSchema = toSwagger defaultOpenIdClientDetailDto diff --git a/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientSimpleJM.hs b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientSimpleJM.hs new file mode 100644 index 000000000..ec373fe57 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientSimpleJM.hs @@ -0,0 +1,13 @@ +module WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientSimpleJM where + +import Data.Aeson + +import Shared.Common.Util.Aeson +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientStyleJM () +import WizardLib.Public.Model.OpenId.OpenIdClientSimple + +instance FromJSON OpenIdClientSimple where + parseJSON = genericParseJSON jsonOptions + +instance ToJSON OpenIdClientSimple where + toJSON = genericToJSON jsonOptions diff --git a/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientSimpleSM.hs b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientSimpleSM.hs new file mode 100644 index 000000000..4f7a5401f --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Api/Resource/OpenId/Client/Definition/OpenIdClientSimpleSM.hs @@ -0,0 +1,12 @@ +module WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientSimpleSM where + +import Data.Swagger + +import Shared.Common.Util.Swagger +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientStyleSM () +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientSimpleJM () +import WizardLib.Public.Database.Migration.Development.OpenId.Data.OpenIdClients +import WizardLib.Public.Model.OpenId.OpenIdClientSimple + +instance ToSchema OpenIdClientSimple where + declareNamedSchema = toSwagger defaultOpenIdClientSimple diff --git a/wizard-public/src/WizardLib/Public/Api/Resource/User/UserFromExternalDTO.hs b/wizard-public/src/WizardLib/Public/Api/Resource/User/UserFromExternalDTO.hs new file mode 100644 index 000000000..4816e6e3c --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Api/Resource/User/UserFromExternalDTO.hs @@ -0,0 +1,11 @@ +module WizardLib.Public.Api.Resource.User.UserFromExternalDTO where + +import GHC.Generics + +data UserFromExternalDTO = UserFromExternalDTO + { hash :: String + , email :: String + , firstName :: String + , lastName :: String + } + deriving (Generic, Show) diff --git a/wizard-public/src/WizardLib/Public/Api/Resource/User/UserFromExternalJM.hs b/wizard-public/src/WizardLib/Public/Api/Resource/User/UserFromExternalJM.hs new file mode 100644 index 000000000..5b5cdc87f --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Api/Resource/User/UserFromExternalJM.hs @@ -0,0 +1,12 @@ +module WizardLib.Public.Api.Resource.User.UserFromExternalJM where + +import Data.Aeson + +import Shared.Common.Util.Aeson +import WizardLib.Public.Api.Resource.User.UserFromExternalDTO + +instance FromJSON UserFromExternalDTO where + parseJSON = genericParseJSON jsonOptions + +instance ToJSON UserFromExternalDTO where + toJSON = genericToJSON jsonOptions diff --git a/wizard-public/src/WizardLib/Public/Api/Resource/User/UserFromExternalSM.hs b/wizard-public/src/WizardLib/Public/Api/Resource/User/UserFromExternalSM.hs new file mode 100644 index 000000000..4e25741b2 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Api/Resource/User/UserFromExternalSM.hs @@ -0,0 +1,17 @@ +module WizardLib.Public.Api.Resource.User.UserFromExternalSM where + +import Data.Swagger + +import Shared.Common.Util.Swagger +import WizardLib.Public.Api.Resource.User.UserFromExternalDTO +import WizardLib.Public.Api.Resource.User.UserFromExternalJM () + +instance ToSchema UserFromExternalDTO where + declareNamedSchema = + toSwagger + UserFromExternalDTO + { hash = "00000000-0000-0000-0000-000000000000" + , email = "albert.einstein@example.com" + , firstName = "Albert" + , lastName = "Einstein" + } diff --git a/wizard-public/src/WizardLib/Public/Api/Resource/User/UserOpenIdIdentityDTO.hs b/wizard-public/src/WizardLib/Public/Api/Resource/User/UserOpenIdIdentityDTO.hs new file mode 100644 index 000000000..5ed0d3c22 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Api/Resource/User/UserOpenIdIdentityDTO.hs @@ -0,0 +1,18 @@ +module WizardLib.Public.Api.Resource.User.UserOpenIdIdentityDTO where + +import Data.Time +import qualified Data.UUID as U +import GHC.Generics + +import Shared.OpenId.Model.OpenId.OpenIdClientStyle + +data UserOpenIdIdentityDTO = UserOpenIdIdentityDTO + { uuid :: U.UUID + , externalId :: String + , externalLabel :: Maybe String + , providerUuid :: U.UUID + , providerName :: String + , providerStyle :: OpenIdClientStyle + , createdAt :: UTCTime + } + deriving (Generic, Show) diff --git a/wizard-public/src/WizardLib/Public/Api/Resource/User/UserOpenIdIdentityJM.hs b/wizard-public/src/WizardLib/Public/Api/Resource/User/UserOpenIdIdentityJM.hs new file mode 100644 index 000000000..566eef71f --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Api/Resource/User/UserOpenIdIdentityJM.hs @@ -0,0 +1,13 @@ +module WizardLib.Public.Api.Resource.User.UserOpenIdIdentityJM where + +import Data.Aeson + +import Shared.Common.Util.Aeson +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientStyleJM () +import WizardLib.Public.Api.Resource.User.UserOpenIdIdentityDTO + +instance FromJSON UserOpenIdIdentityDTO where + parseJSON = genericParseJSON jsonOptions + +instance ToJSON UserOpenIdIdentityDTO where + toJSON = genericToJSON jsonOptions diff --git a/wizard-public/src/WizardLib/Public/Api/Resource/User/UserOpenIdIdentitySM.hs b/wizard-public/src/WizardLib/Public/Api/Resource/User/UserOpenIdIdentitySM.hs new file mode 100644 index 000000000..bd12bc327 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Api/Resource/User/UserOpenIdIdentitySM.hs @@ -0,0 +1,12 @@ +module WizardLib.Public.Api.Resource.User.UserOpenIdIdentitySM where + +import Data.Swagger + +import Shared.Common.Util.Swagger +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientStyleSM () +import WizardLib.Public.Api.Resource.User.UserOpenIdIdentityDTO +import WizardLib.Public.Api.Resource.User.UserOpenIdIdentityJM () +import WizardLib.Public.Database.Migration.Development.User.Data.UserOpenIdIdentities + +instance ToSchema UserOpenIdIdentityDTO where + declareNamedSchema = toSwagger defaultUserOpenIdIdentityDto diff --git a/wizard-public/src/WizardLib/Public/Api/Resource/UserToken/UserTokenDTO.hs b/wizard-public/src/WizardLib/Public/Api/Resource/UserToken/UserTokenDTO.hs index 46efbcde4..3975429b7 100644 --- a/wizard-public/src/WizardLib/Public/Api/Resource/UserToken/UserTokenDTO.hs +++ b/wizard-public/src/WizardLib/Public/Api/Resource/UserToken/UserTokenDTO.hs @@ -8,8 +8,17 @@ data UserTokenDTO | ConsentsRequiredDTO { hash :: String } + | CompleteRegistrationRequiredDTO + { hash :: String + , email :: Maybe String + , firstName :: Maybe String + , lastName :: Maybe String + , imageUrl :: Maybe String + } + | IdentityLinkedDTO | UserTokenDTO { token :: String , expiresAt :: UTCTime } + | EmailVerificationRequiredDTO deriving (Show, Eq, Generic) diff --git a/wizard-public/src/WizardLib/Public/Database/DAO/OpenId/OpenIdClientDefinitionDAO.hs b/wizard-public/src/WizardLib/Public/Database/DAO/OpenId/OpenIdClientDefinitionDAO.hs new file mode 100644 index 000000000..69013c6fa --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Database/DAO/OpenId/OpenIdClientDefinitionDAO.hs @@ -0,0 +1,59 @@ +module WizardLib.Public.Database.DAO.OpenId.OpenIdClientDefinitionDAO where + +import Control.Monad.Reader (asks) +import Data.String (fromString) +import qualified Data.UUID as U +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.ToRow +import GHC.Int + +import Shared.Common.Database.DAO.Common +import Shared.Common.Model.Context.AppContext +import WizardLib.Public.Database.Mapping.OpenId.OpenIdClient () +import WizardLib.Public.Database.Mapping.OpenId.OpenIdClientSimple () +import WizardLib.Public.Model.OpenId.OpenIdClient +import WizardLib.Public.Model.OpenId.OpenIdClientSimple + +entityName = "openid_client" + +findOpenIdClientDefinitions :: AppContextC s sc m => m [OpenIdClient] +findOpenIdClientDefinitions = do + tenantUuid <- asks (.tenantUuid') + createFindEntitiesByFn entityName [tenantQueryUuid tenantUuid] + +findOpenIdClientDefinitionsSimpleByTenantUuid :: AppContextC s sc m => U.UUID -> m [OpenIdClientSimple] +findOpenIdClientDefinitionsSimpleByTenantUuid tenantUuid = + createFindEntitiesWithFieldsByFn "uuid, name, url, style" entityName [tenantQueryUuid tenantUuid] + +findOpenIdClientDefinitionByUuid :: AppContextC s sc m => U.UUID -> m OpenIdClient +findOpenIdClientDefinitionByUuid uuid = do + tenantUuid <- asks (.tenantUuid') + createFindEntityByFn entityName [tenantQueryUuid tenantUuid, ("uuid", U.toString uuid)] + +findOpenIdClientDefinitionByUuid' :: AppContextC s sc m => U.UUID -> m (Maybe OpenIdClient) +findOpenIdClientDefinitionByUuid' uuid = do + tenantUuid <- asks (.tenantUuid') + createFindEntityByFn' entityName [tenantQueryUuid tenantUuid, ("uuid", U.toString uuid)] + +insertOpenIdClientDefinition :: AppContextC s sc m => OpenIdClient -> m Int64 +insertOpenIdClientDefinition = createInsertFn entityName + +updateOpenIdClientDefinition :: AppContextC s sc m => OpenIdClient -> m Int64 +updateOpenIdClientDefinition openIdClient = do + let sql = + fromString + "UPDATE openid_client SET uuid = ?, name = ?, url = ?, client_id = ?, client_secret = ?, parameters = ?, style = ?, tenant_uuid = ?, created_at = ?, updated_at = ?, registration_enabled = ?, scope_profile = ?, scope_email = ? WHERE uuid = ? AND tenant_uuid = ?" + let params = toRow openIdClient ++ [toField openIdClient.uuid, toField openIdClient.tenantUuid] + logQuery sql params + let action conn = execute conn sql params + runDB action + +deleteOpenIdClientDefinitionDefinitions :: AppContextC s sc m => m Int64 +deleteOpenIdClientDefinitionDefinitions = createDeleteEntitiesFn entityName + +deleteOpenIdClientDefinitionByUuid :: AppContextC s sc m => U.UUID -> m () +deleteOpenIdClientDefinitionByUuid uuid = do + tenantUuid <- asks (.tenantUuid') + createDeleteEntityByFn entityName [tenantQueryUuid tenantUuid, ("uuid", U.toString uuid)] + return () diff --git a/wizard-public/src/WizardLib/Public/Database/DAO/PersistentCommand/PersistentCommandDAO.hs b/wizard-public/src/WizardLib/Public/Database/DAO/PersistentCommand/PersistentCommandDAO.hs new file mode 100644 index 000000000..43f8656e4 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Database/DAO/PersistentCommand/PersistentCommandDAO.hs @@ -0,0 +1,38 @@ +module WizardLib.Public.Database.DAO.PersistentCommand.PersistentCommandDAO where + +import Data.String (fromString) +import qualified Data.UUID as U +import Database.PostgreSQL.Simple + +import Shared.Common.Database.DAO.Common +import Shared.Common.Model.Context.AppContext +import Shared.Common.Util.Logger +import Shared.Common.Util.String (f'') +import Shared.PersistentCommand.Database.Mapping.PersistentCommand.LambdaInvocationResult () +import Shared.PersistentCommand.Database.Mapping.PersistentCommand.PersistentCommand () +import Shared.PersistentCommand.Database.Mapping.PersistentCommand.PersistentCommandSimple () +import Shared.PersistentCommand.Model.PersistentCommand.PersistentCommandSimple + +findPersistentCommandsForLambdaByStates :: AppContextC s sc m => [String] -> m [PersistentCommandSimple U.UUID] +findPersistentCommandsForLambdaByStates components = do + let componentCondition = + case components of + [] -> "" + _ -> f' "AND component IN (%s) " [generateQuestionMarks components] + let sql = + fromString $ + f'' + "SELECT uuid, destination, component, tenant_uuid, created_by \ + \FROM persistent_command \ + \WHERE (state = 'NewPersistentCommandState' \ + \ OR (state = 'ErrorPersistentCommandState' AND attempts < max_attempts AND updated_at < (now() - (2 ^ attempts - 1) * INTERVAL '1 min'))) \ + \ AND internal = false ${componentCondition} \ + \ORDER BY created_at \ + \LIMIT 5 \ + \FOR UPDATE" + [ ("componentCondition", componentCondition) + ] + let params = components + logQuery sql params + let action conn = query conn sql params + runDB action diff --git a/wizard-public/src/WizardLib/Public/Database/DAO/User/UserOpenIdIdentityDAO.hs b/wizard-public/src/WizardLib/Public/Database/DAO/User/UserOpenIdIdentityDAO.hs new file mode 100644 index 000000000..497ddb161 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Database/DAO/User/UserOpenIdIdentityDAO.hs @@ -0,0 +1,55 @@ +module WizardLib.Public.Database.DAO.User.UserOpenIdIdentityDAO where + +import Control.Monad.Reader (asks) +import Data.String (fromString) +import qualified Data.UUID as U +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.ToField +import GHC.Int + +import Shared.Common.Database.DAO.Common +import Shared.Common.Model.Context.AppContext +import WizardLib.Public.Database.Mapping.User.UserOpenIdIdentity () +import WizardLib.Public.Database.Mapping.User.UserOpenIdIdentityList () +import WizardLib.Public.Model.User.UserOpenIdIdentity +import WizardLib.Public.Model.User.UserOpenIdIdentityList + +entityName = "user_openid_identity" + +findUserOpenIdIdentitiesByUserUuid :: AppContextC s sc m => U.UUID -> m [UserOpenIdIdentity] +findUserOpenIdIdentitiesByUserUuid userUuid = do + tenantUuid <- asks (.tenantUuid') + createFindEntitiesByFn entityName [tenantQueryUuid tenantUuid, ("user_uuid", U.toString userUuid)] + +findUserOpenIdIdentityListsByUserUuid :: AppContextC s sc m => U.UUID -> m [UserOpenIdIdentityList] +findUserOpenIdIdentityListsByUserUuid userUuid = do + tenantUuid <- asks (.tenantUuid') + let sql = + fromString + "SELECT i.uuid, i.external_id, i.external_label, i.provider_uuid, oc.name, oc.style, i.created_at \ + \FROM user_openid_identity i \ + \JOIN openid_client oc ON oc.uuid = i.provider_uuid \ + \WHERE i.user_uuid = ? AND i.tenant_uuid = ?" + let params = [toField userUuid, toField tenantUuid] + logQuery sql params + let action conn = query conn sql params + runDB action + +findUserOpenIdIdentityByExternalIdAndProvider' :: AppContextC s sc m => String -> U.UUID -> m (Maybe UserOpenIdIdentity) +findUserOpenIdIdentityByExternalIdAndProvider' externalId providerUuid = do + tenantUuid <- asks (.tenantUuid') + createFindEntityByFn' + entityName + [tenantQueryUuid tenantUuid, ("external_id", externalId), ("provider_uuid", U.toString providerUuid)] + +insertUserOpenIdIdentity :: AppContextC s sc m => UserOpenIdIdentity -> m Int64 +insertUserOpenIdIdentity = createInsertFn entityName + +deleteUserOpenIdIdentities :: AppContextC s sc m => m Int64 +deleteUserOpenIdIdentities = createDeleteEntitiesFn entityName + +deleteUserOpenIdIdentityByUuid :: AppContextC s sc m => U.UUID -> m () +deleteUserOpenIdIdentityByUuid uuid = do + tenantUuid <- asks (.tenantUuid') + createDeleteEntityByFn entityName [tenantQueryUuid tenantUuid, ("uuid", U.toString uuid)] + return () diff --git a/wizard-public/src/WizardLib/Public/Database/DAO/User/UserRegistrationPendingDAO.hs b/wizard-public/src/WizardLib/Public/Database/DAO/User/UserRegistrationPendingDAO.hs new file mode 100644 index 000000000..8d4baa01f --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Database/DAO/User/UserRegistrationPendingDAO.hs @@ -0,0 +1,78 @@ +module WizardLib.Public.Database.DAO.User.UserRegistrationPendingDAO where + +import Control.Monad.Reader (asks) +import Data.String (fromString) +import Data.Time +import qualified Data.UUID as U +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.ToRow +import GHC.Int + +import Shared.Common.Database.DAO.Common +import Shared.Common.Model.Context.AppContext +import WizardLib.Public.Database.Mapping.User.UserRegistrationPending () +import WizardLib.Public.Model.User.UserRegistrationPending + +entityName = "user_registration_pending" + +findUserRegistrationPendingByHash + :: (AppContextC s sc m, FromField serviceType) => String -> m (UserRegistrationPending serviceType) +findUserRegistrationPendingByHash hash = do + tenantUuid <- asks (.tenantUuid') + createFindEntityByFn entityName [tenantQueryUuid tenantUuid, ("hash", hash)] + +findUserRegistrationPendingByServiceTypeAndExternalIdAndProviderUuid' + :: (AppContextC s sc m, FromField serviceType, Show serviceType) + => serviceType + -> String + -> U.UUID + -> m (Maybe (UserRegistrationPending serviceType)) +findUserRegistrationPendingByServiceTypeAndExternalIdAndProviderUuid' serviceType externalId providerUuid = do + tenantUuid <- asks (.tenantUuid') + createFindEntityByFn' + entityName + [ tenantQueryUuid tenantUuid + , ("service_type", show serviceType) + , ("external_id", externalId) + , ("provider_uuid", U.toString providerUuid) + ] + +insertUserRegistrationPending + :: (AppContextC s sc m, ToField serviceType) => UserRegistrationPending serviceType -> m Int64 +insertUserRegistrationPending = createInsertFn entityName + +updateUserRegistrationPendingByUuid + :: (AppContextC s sc m, ToField serviceType) => UserRegistrationPending serviceType -> m Int64 +updateUserRegistrationPendingByUuid pending = do + let sql = + fromString + "UPDATE user_registration_pending SET uuid = ?, hash = ?, service_type = ?, provider_uuid = ?, external_id = ?, external_label = ?, email = ?, first_name = ?, last_name = ?, image_url = ?, affiliation = ?, tenant_uuid = ?, created_at = ? WHERE uuid = ? AND tenant_uuid = ?" + let params = toRow pending ++ [toField pending.uuid, toField pending.tenantUuid] + logQuery sql params + let action conn = execute conn sql params + runDB action + +deleteUserRegistrationPendings :: AppContextC s sc m => m Int64 +deleteUserRegistrationPendings = createDeleteEntitiesFn entityName + +deleteUserRegistrationPendingByUuid :: AppContextC s sc m => U.UUID -> m () +deleteUserRegistrationPendingByUuid uuid = do + tenantUuid <- asks (.tenantUuid') + createDeleteEntityByFn entityName [tenantQueryUuid tenantUuid, ("uuid", U.toString uuid)] + return () + +deleteUserRegistrationPendingByHash :: AppContextC s sc m => String -> m () +deleteUserRegistrationPendingByHash hash = do + tenantUuid <- asks (.tenantUuid') + createDeleteEntityByFn entityName [tenantQueryUuid tenantUuid, ("hash", hash)] + return () + +deleteUserRegistrationPendingsOlderThan :: AppContextC s sc m => UTCTime -> m Int64 +deleteUserRegistrationPendingsOlderThan threshold = do + let sql = fromString "DELETE FROM user_registration_pending WHERE created_at < ?" + let params = [toField threshold] + logQuery sql params + let action conn = execute conn sql params + runDB action diff --git a/wizard-public/src/WizardLib/Public/Database/Mapping/OpenId/OpenIdClient.hs b/wizard-public/src/WizardLib/Public/Database/Mapping/OpenId/OpenIdClient.hs new file mode 100644 index 000000000..ba2f0549b --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Database/Mapping/OpenId/OpenIdClient.hs @@ -0,0 +1,45 @@ +module WizardLib.Public.Database.Mapping.OpenId.OpenIdClient where + +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.FromRow +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.ToRow + +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientParameterJM () +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientStyleJM () +import WizardLib.Public.Model.OpenId.OpenIdClient + +instance ToRow OpenIdClient where + toRow OpenIdClient {..} = + [ toField uuid + , toField name + , toField url + , toField clientId + , toField clientSecret + , toJSONField parameters + , toJSONField style + , toField tenantUuid + , toField createdAt + , toField updatedAt + , toField registrationEnabled + , toField scopeProfile + , toField scopeEmail + ] + +instance FromRow OpenIdClient where + fromRow = do + uuid <- field + name <- field + url <- field + clientId <- field + clientSecret <- field + parameters <- fieldWith fromJSONField + style <- fieldWith fromJSONField + tenantUuid <- field + createdAt <- field + updatedAt <- field + registrationEnabled <- field + scopeProfile <- field + scopeEmail <- field + return $ OpenIdClient {..} diff --git a/wizard-public/src/WizardLib/Public/Database/Mapping/OpenId/OpenIdClientSimple.hs b/wizard-public/src/WizardLib/Public/Database/Mapping/OpenId/OpenIdClientSimple.hs new file mode 100644 index 000000000..c5ec56a2c --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Database/Mapping/OpenId/OpenIdClientSimple.hs @@ -0,0 +1,16 @@ +module WizardLib.Public.Database.Mapping.OpenId.OpenIdClientSimple where + +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.FromRow + +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientStyleJM () +import WizardLib.Public.Model.OpenId.OpenIdClientSimple + +instance FromRow OpenIdClientSimple where + fromRow = do + uuid <- field + name <- field + url <- field + style <- fieldWith fromJSONField + return $ OpenIdClientSimple {..} diff --git a/wizard-public/src/WizardLib/Public/Database/Mapping/Tenant/Config/TenantConfigMail.hs b/wizard-public/src/WizardLib/Public/Database/Mapping/Tenant/Config/TenantConfigMail.hs index 43f4cafad..3cd90f29d 100644 --- a/wizard-public/src/WizardLib/Public/Database/Mapping/Tenant/Config/TenantConfigMail.hs +++ b/wizard-public/src/WizardLib/Public/Database/Mapping/Tenant/Config/TenantConfigMail.hs @@ -1,10 +1,27 @@ module WizardLib.Public.Database.Mapping.Tenant.Config.TenantConfigMail where import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.FromRow +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.ToRow import Shared.Common.Database.Mapping.Common () import WizardLib.Public.Model.Tenant.Config.TenantConfig -instance FromRow TenantConfigMail +instance FromRow TenantConfigMail where + fromRow = do + tenantUuid <- field + configUuid <- field + createdAt <- field + updatedAt <- field + customTemplates <- field + return $ TenantConfigMail {..} -instance ToRow TenantConfigMail +instance ToRow TenantConfigMail where + toRow TenantConfigMail {..} = + [ toField tenantUuid + , toField configUuid + , toField createdAt + , toField updatedAt + , toField customTemplates + ] diff --git a/wizard-public/src/WizardLib/Public/Database/Mapping/User/UserOpenIdIdentity.hs b/wizard-public/src/WizardLib/Public/Database/Mapping/User/UserOpenIdIdentity.hs new file mode 100644 index 000000000..aca49a3b0 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Database/Mapping/User/UserOpenIdIdentity.hs @@ -0,0 +1,29 @@ +module WizardLib.Public.Database.Mapping.User.UserOpenIdIdentity where + +import Database.PostgreSQL.Simple.FromRow +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.ToRow + +import WizardLib.Public.Model.User.UserOpenIdIdentity + +instance ToRow UserOpenIdIdentity where + toRow UserOpenIdIdentity {..} = + [ toField uuid + , toField externalId + , toField externalLabel + , toField userUuid + , toField providerUuid + , toField tenantUuid + , toField createdAt + ] + +instance FromRow UserOpenIdIdentity where + fromRow = do + uuid <- field + externalId <- field + externalLabel <- field + userUuid <- field + providerUuid <- field + tenantUuid <- field + createdAt <- field + return $ UserOpenIdIdentity {..} diff --git a/wizard-public/src/WizardLib/Public/Database/Mapping/User/UserOpenIdIdentityList.hs b/wizard-public/src/WizardLib/Public/Database/Mapping/User/UserOpenIdIdentityList.hs new file mode 100644 index 000000000..641be6ab5 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Database/Mapping/User/UserOpenIdIdentityList.hs @@ -0,0 +1,19 @@ +module WizardLib.Public.Database.Mapping.User.UserOpenIdIdentityList where + +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.FromRow + +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientStyleJM () +import WizardLib.Public.Model.User.UserOpenIdIdentityList + +instance FromRow UserOpenIdIdentityList where + fromRow = do + uuid <- field + externalId <- field + externalLabel <- field + providerUuid <- field + providerName <- field + providerStyle <- fieldWith fromJSONField + createdAt <- field + return $ UserOpenIdIdentityList {..} diff --git a/wizard-public/src/WizardLib/Public/Database/Mapping/User/UserRegistrationPending.hs b/wizard-public/src/WizardLib/Public/Database/Mapping/User/UserRegistrationPending.hs new file mode 100644 index 000000000..acbc47007 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Database/Mapping/User/UserRegistrationPending.hs @@ -0,0 +1,42 @@ +module WizardLib.Public.Database.Mapping.User.UserRegistrationPending where + +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.FromRow +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.ToRow + +import WizardLib.Public.Model.User.UserRegistrationPending + +instance ToField serviceType => ToRow (UserRegistrationPending serviceType) where + toRow UserRegistrationPending {..} = + [ toField uuid + , toField hash + , toField serviceType + , toField providerUuid + , toField externalId + , toField externalLabel + , toField email + , toField firstName + , toField lastName + , toField imageUrl + , toField affiliation + , toField tenantUuid + , toField createdAt + ] + +instance FromField serviceType => FromRow (UserRegistrationPending serviceType) where + fromRow = do + uuid <- field + hash <- field + serviceType <- field + providerUuid <- field + externalId <- field + externalLabel <- field + email <- field + firstName <- field + lastName <- field + imageUrl <- field + affiliation <- field + tenantUuid <- field + createdAt <- field + return $ UserRegistrationPending {..} diff --git a/wizard-public/src/WizardLib/Public/Database/Migration/Development/OpenId/Data/OpenIdClients.hs b/wizard-public/src/WizardLib/Public/Database/Migration/Development/OpenId/Data/OpenIdClients.hs new file mode 100644 index 000000000..72c22bf13 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Database/Migration/Development/OpenId/Data/OpenIdClients.hs @@ -0,0 +1,101 @@ +module WizardLib.Public.Database.Migration.Development.OpenId.Data.OpenIdClients where + +import Shared.Common.Constant.Tenant +import Shared.Common.Util.Date +import Shared.Common.Util.Uuid +import Shared.OpenId.Database.Migration.Development.OpenId.Data.OpenIds +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeDTO +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailDTO +import WizardLib.Public.Model.OpenId.OpenIdClient +import WizardLib.Public.Model.OpenId.OpenIdClientSimple + +defaultOpenIdClient :: OpenIdClient +defaultOpenIdClient = + OpenIdClient + { uuid = u' "cb7558d8-5e78-4494-9b94-0e9d64676923" + , name = "Google" + , url = "https://accounts.google.com" + , clientId = "32559869123-a98908094.apps.googleusercontent.com" + , clientSecret = "sad89089023" + , parameters = [openIdClientDefinitionParameter] + , style = openIdClientDefinitionStyle + , registrationEnabled = True + , scopeProfile = True + , scopeEmail = True + , tenantUuid = defaultTenantUuid + , createdAt = dt' 2018 1 20 + , updatedAt = dt' 2018 1 20 + } + +defaultOpenIdClientSimple :: OpenIdClientSimple +defaultOpenIdClientSimple = + OpenIdClientSimple + { uuid = defaultOpenIdClient.uuid + , name = defaultOpenIdClient.name + , url = defaultOpenIdClient.url + , style = defaultOpenIdClient.style + } + +defaultOpenIdClientDetailDto :: OpenIdClientDetailDTO +defaultOpenIdClientDetailDto = + OpenIdClientDetailDTO + { uuid = defaultOpenIdClient.uuid + , name = defaultOpenIdClient.name + , url = defaultOpenIdClient.url + , clientId = defaultOpenIdClient.clientId + , clientSecret = defaultOpenIdClient.clientSecret + , parameters = defaultOpenIdClient.parameters + , style = defaultOpenIdClient.style + , registrationEnabled = defaultOpenIdClient.registrationEnabled + , scopeProfile = defaultOpenIdClient.scopeProfile + , scopeEmail = defaultOpenIdClient.scopeEmail + , tenantUuid = defaultOpenIdClient.tenantUuid + , createdAt = defaultOpenIdClient.createdAt + , updatedAt = defaultOpenIdClient.updatedAt + } + +defaultOpenIdClientChangeDto :: OpenIdClientChangeDTO +defaultOpenIdClientChangeDto = + OpenIdClientChangeDTO + { name = "UPDATED: Google" + , url = "https://accounts.google.com/updated" + , clientId = "32559869123-a98908094.apps.googleusercontent.com/updated" + , clientSecret = "sad89089023Updated" + , parameters = [openIdClientDefinitionParameter] + , style = openIdClientDefinitionStyle + , registrationEnabled = True + , scopeProfile = True + , scopeEmail = True + } + +editedOpenIdClient :: OpenIdClient +editedOpenIdClient = + defaultOpenIdClient + { name = defaultOpenIdClientChangeDto.name + , url = defaultOpenIdClientChangeDto.url + , clientId = defaultOpenIdClientChangeDto.clientId + , clientSecret = defaultOpenIdClientChangeDto.clientSecret + , parameters = defaultOpenIdClientChangeDto.parameters + , style = defaultOpenIdClientChangeDto.style + , registrationEnabled = defaultOpenIdClientChangeDto.registrationEnabled + , scopeProfile = defaultOpenIdClientChangeDto.scopeProfile + , scopeEmail = defaultOpenIdClientChangeDto.scopeEmail + } + +editedOpenIdClientDetailDto :: OpenIdClientDetailDTO +editedOpenIdClientDetailDto = + OpenIdClientDetailDTO + { uuid = editedOpenIdClient.uuid + , name = editedOpenIdClient.name + , url = editedOpenIdClient.url + , clientId = editedOpenIdClient.clientId + , clientSecret = editedOpenIdClient.clientSecret + , parameters = editedOpenIdClient.parameters + , style = editedOpenIdClient.style + , registrationEnabled = editedOpenIdClient.registrationEnabled + , scopeProfile = editedOpenIdClient.scopeProfile + , scopeEmail = editedOpenIdClient.scopeEmail + , tenantUuid = editedOpenIdClient.tenantUuid + , createdAt = editedOpenIdClient.createdAt + , updatedAt = editedOpenIdClient.updatedAt + } diff --git a/wizard-public/src/WizardLib/Public/Database/Migration/Development/OpenId/OpenIdClientMigration.hs b/wizard-public/src/WizardLib/Public/Database/Migration/Development/OpenId/OpenIdClientMigration.hs new file mode 100644 index 000000000..3c0de20e3 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Database/Migration/Development/OpenId/OpenIdClientMigration.hs @@ -0,0 +1,16 @@ +module WizardLib.Public.Database.Migration.Development.OpenId.OpenIdClientMigration where + +import Control.Monad (void) + +import Shared.Common.Constant.Component +import Shared.Common.Model.Context.AppContext +import Shared.Common.Util.Logger +import WizardLib.Public.Database.DAO.OpenId.OpenIdClientDefinitionDAO +import WizardLib.Public.Database.Migration.Development.OpenId.Data.OpenIdClients + +runMigration :: AppContextC s sc m => m () +runMigration = do + logInfo _CMP_MIGRATION "(OpenId/OpenIdClient) started" + _ <- deleteOpenIdClientDefinitionDefinitions + void $ insertOpenIdClientDefinition defaultOpenIdClient + logInfo _CMP_MIGRATION "(OpenId/OpenIdClient) ended" diff --git a/wizard-public/src/WizardLib/Public/Database/Migration/Development/OpenId/OpenIdClientSchemaMigration.hs b/wizard-public/src/WizardLib/Public/Database/Migration/Development/OpenId/OpenIdClientSchemaMigration.hs new file mode 100644 index 000000000..df415914c --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Database/Migration/Development/OpenId/OpenIdClientSchemaMigration.hs @@ -0,0 +1,40 @@ +module WizardLib.Public.Database.Migration.Development.OpenId.OpenIdClientSchemaMigration where + +import Database.PostgreSQL.Simple +import GHC.Int + +import Shared.Common.Database.DAO.Common +import Shared.Common.Model.Context.AppContext +import Shared.Common.Util.Logger + +dropTables :: AppContextC s sc m => m Int64 +dropTables = do + logInfo _CMP_MIGRATION "(Table/OpenIdClient) drop tables" + let sql = "DROP TABLE IF EXISTS openid_client CASCADE;" + let action conn = execute_ conn sql + runDB action + +createTables :: AppContextC s sc m => m Int64 +createTables = do + logInfo _CMP_MIGRATION "(Table/OpenIdClient) create table" + let sql = + "CREATE TABLE openid_client \ + \( \ + \ uuid uuid NOT NULL, \ + \ name varchar NOT NULL, \ + \ url varchar NOT NULL, \ + \ client_id varchar NOT NULL, \ + \ client_secret varchar NOT NULL, \ + \ parameters jsonb NOT NULL, \ + \ style jsonb NOT NULL, \ + \ tenant_uuid uuid NOT NULL, \ + \ created_at timestamptz NOT NULL, \ + \ updated_at timestamptz NOT NULL, \ + \ registration_enabled bool NOT NULL, \ + \ scope_profile bool NOT NULL, \ + \ scope_email bool NOT NULL, \ + \ CONSTRAINT openid_client_pk PRIMARY KEY (uuid), \ + \ CONSTRAINT openid_client_tenant_uuid_fk FOREIGN KEY (tenant_uuid) REFERENCES tenant (uuid) ON DELETE CASCADE \ + \);" + let action conn = execute_ conn sql + runDB action diff --git a/wizard-public/src/WizardLib/Public/Database/Migration/Development/Tenant/Data/TenantConfigs.hs b/wizard-public/src/WizardLib/Public/Database/Migration/Development/Tenant/Data/TenantConfigs.hs index 91f6d8535..447fc8acb 100644 --- a/wizard-public/src/WizardLib/Public/Database/Migration/Development/Tenant/Data/TenantConfigs.hs +++ b/wizard-public/src/WizardLib/Public/Database/Migration/Development/Tenant/Data/TenantConfigs.hs @@ -59,6 +59,7 @@ defaultMail = TenantConfigMail { tenantUuid = defaultTenantUuid , configUuid = Nothing + , customTemplates = False , createdAt = dt' 2018 1 20 , updatedAt = dt' 2018 1 20 } diff --git a/wizard-public/src/WizardLib/Public/Database/Migration/Development/User/Data/UserOpenIdIdentities.hs b/wizard-public/src/WizardLib/Public/Database/Migration/Development/User/Data/UserOpenIdIdentities.hs new file mode 100644 index 000000000..a6649dc85 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Database/Migration/Development/User/Data/UserOpenIdIdentities.hs @@ -0,0 +1,20 @@ +module WizardLib.Public.Database.Migration.Development.User.Data.UserOpenIdIdentities where + +import Shared.Common.Util.Date +import Shared.Common.Util.Uuid +import Shared.OpenId.Database.Migration.Development.OpenId.Data.OpenIds +import WizardLib.Public.Api.Resource.User.UserOpenIdIdentityDTO +import WizardLib.Public.Database.Migration.Development.OpenId.Data.OpenIdClients +import WizardLib.Public.Model.OpenId.OpenIdClient + +defaultUserOpenIdIdentityDto :: UserOpenIdIdentityDTO +defaultUserOpenIdIdentityDto = + UserOpenIdIdentityDTO + { uuid = u' "ec6f8e90-2a91-49ec-aa3f-9eab2267fc66" + , externalId = "albert.einstein@example.com" + , externalLabel = Just "Albert" + , providerUuid = (defaultOpenIdClient :: OpenIdClient).uuid + , providerName = (defaultOpenIdClient :: OpenIdClient).name + , providerStyle = openIdClientDefinitionStyle + , createdAt = dt' 2018 1 21 + } diff --git a/wizard-public/src/WizardLib/Public/Database/Migration/Development/User/UserOpenIdIdentitySchemaMigration.hs b/wizard-public/src/WizardLib/Public/Database/Migration/Development/User/UserOpenIdIdentitySchemaMigration.hs new file mode 100644 index 000000000..44fb81fe2 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Database/Migration/Development/User/UserOpenIdIdentitySchemaMigration.hs @@ -0,0 +1,37 @@ +module WizardLib.Public.Database.Migration.Development.User.UserOpenIdIdentitySchemaMigration where + +import Database.PostgreSQL.Simple +import GHC.Int + +import Shared.Common.Database.DAO.Common +import Shared.Common.Model.Context.AppContext +import Shared.Common.Util.Logger + +dropTables :: AppContextC s sc m => m Int64 +dropTables = do + logInfo _CMP_MIGRATION "(Table/UserOpenIdIdentity) drop tables" + let sql = "DROP TABLE IF EXISTS user_openid_identity CASCADE;" + let action conn = execute_ conn sql + runDB action + +createTables :: AppContextC s sc m => m Int64 +createTables = do + logInfo _CMP_MIGRATION "(Table/UserOpenIdIdentity) create table" + let sql = + "CREATE TABLE user_openid_identity \ + \( \ + \ uuid uuid NOT NULL, \ + \ external_id varchar NOT NULL, \ + \ external_label varchar, \ + \ user_uuid uuid NOT NULL, \ + \ provider_uuid uuid NOT NULL, \ + \ tenant_uuid uuid NOT NULL, \ + \ created_at timestamptz NOT NULL, \ + \ CONSTRAINT user_openid_identity_pk PRIMARY KEY (uuid), \ + \ CONSTRAINT user_openid_identity_user_uuid_fk FOREIGN KEY (user_uuid) REFERENCES user_entity (uuid) ON DELETE CASCADE, \ + \ CONSTRAINT user_openid_identity_provider_uuid_fk FOREIGN KEY (provider_uuid) REFERENCES openid_client (uuid) ON DELETE CASCADE, \ + \ CONSTRAINT user_openid_identity_tenant_uuid_fk FOREIGN KEY (tenant_uuid) REFERENCES tenant (uuid) ON DELETE CASCADE \ + \); \ + \CREATE UNIQUE INDEX user_openid_identity_uindex ON user_openid_identity (external_id, provider_uuid, tenant_uuid);" + let action conn = execute_ conn sql + runDB action diff --git a/wizard-public/src/WizardLib/Public/Database/Migration/Development/User/UserRegistrationPendingSchemaMigration.hs b/wizard-public/src/WizardLib/Public/Database/Migration/Development/User/UserRegistrationPendingSchemaMigration.hs new file mode 100644 index 000000000..6454fcaf1 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Database/Migration/Development/User/UserRegistrationPendingSchemaMigration.hs @@ -0,0 +1,41 @@ +module WizardLib.Public.Database.Migration.Development.User.UserRegistrationPendingSchemaMigration where + +import Database.PostgreSQL.Simple +import GHC.Int + +import Shared.Common.Database.DAO.Common +import Shared.Common.Model.Context.AppContext +import Shared.Common.Util.Logger + +dropTables :: AppContextC s sc m => m Int64 +dropTables = do + logInfo _CMP_MIGRATION "(Table/UserRegistrationPending) drop tables" + let sql = "DROP TABLE IF EXISTS user_registration_pending CASCADE;" + let action conn = execute_ conn sql + runDB action + +createTables :: AppContextC s sc m => m Int64 +createTables = do + logInfo _CMP_MIGRATION "(Table/UserRegistrationPending) create table" + let sql = + "CREATE TABLE user_registration_pending \ + \( \ + \ uuid uuid NOT NULL, \ + \ hash varchar NOT NULL, \ + \ service_type varchar NOT NULL, \ + \ provider_uuid uuid NOT NULL, \ + \ external_id varchar NOT NULL, \ + \ external_label varchar, \ + \ email varchar, \ + \ first_name varchar, \ + \ last_name varchar, \ + \ image_url varchar, \ + \ affiliation varchar, \ + \ tenant_uuid uuid NOT NULL, \ + \ created_at timestamptz NOT NULL, \ + \ CONSTRAINT user_registration_pending_pk PRIMARY KEY (uuid), \ + \ CONSTRAINT user_registration_pending_tenant_uuid_fk FOREIGN KEY (tenant_uuid) REFERENCES tenant (uuid) ON DELETE CASCADE \ + \); \ + \CREATE UNIQUE INDEX user_registration_pending_hash_uindex ON user_registration_pending (hash, tenant_uuid);" + let action conn = execute_ conn sql + runDB action diff --git a/wizard-public/src/WizardLib/Public/Localization/Messages/Public.hs b/wizard-public/src/WizardLib/Public/Localization/Messages/Public.hs index 080df30b0..9ee7c63fe 100644 --- a/wizard-public/src/WizardLib/Public/Localization/Messages/Public.hs +++ b/wizard-public/src/WizardLib/Public/Localization/Messages/Public.hs @@ -30,6 +30,12 @@ _ERROR_VALIDATION__LOCALE_DISABLED_DEFAULT = _ERROR_SERVICE_OPENID__UNABLE_TO_ENCODE_JWT_TOKEN error = LocaleRecord "error.service.auth.unable_to_encode_jwt_token" "Unable to encode JWT token (error: %s)" [error] +_ERROR_SERVICE_OPENID__REGISTRATION_DISABLED = + LocaleRecord "error.service.openid.registration_disabled" "Registration of new accounts via this service is disabled" [] + +_ERROR_SERVICE_OPENID__IDENTITY_LINKED_TO_DIFFERENT_USER = + LocaleRecord "error.service.openid.identity_linked_to_different_user" "This external identity is already linked to a different user" [] + -- Token _ERROR_SERVICE_TOKEN__INCORRECT_EMAIL_OR_PASSWORD = LocaleRecord "error.service.token.incorrect_email_or_password" "Incorrect email or password" [] diff --git a/wizard-public/src/WizardLib/Public/Model/OpenId/OpenIdClient.hs b/wizard-public/src/WizardLib/Public/Model/OpenId/OpenIdClient.hs new file mode 100644 index 000000000..cbb19f528 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Model/OpenId/OpenIdClient.hs @@ -0,0 +1,25 @@ +module WizardLib.Public.Model.OpenId.OpenIdClient where + +import Data.Time +import qualified Data.UUID as U +import GHC.Generics + +import Shared.OpenId.Model.OpenId.OpenIdClientParameter +import Shared.OpenId.Model.OpenId.OpenIdClientStyle + +data OpenIdClient = OpenIdClient + { uuid :: U.UUID + , name :: String + , url :: String + , clientId :: String + , clientSecret :: String + , parameters :: [OpenIdClientParameter] + , style :: OpenIdClientStyle + , tenantUuid :: U.UUID + , createdAt :: UTCTime + , updatedAt :: UTCTime + , registrationEnabled :: Bool + , scopeProfile :: Bool + , scopeEmail :: Bool + } + deriving (Generic, Eq, Show) diff --git a/wizard-public/src/WizardLib/Public/Model/OpenId/OpenIdClientSimple.hs b/wizard-public/src/WizardLib/Public/Model/OpenId/OpenIdClientSimple.hs new file mode 100644 index 000000000..6b93ecf4e --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Model/OpenId/OpenIdClientSimple.hs @@ -0,0 +1,14 @@ +module WizardLib.Public.Model.OpenId.OpenIdClientSimple where + +import qualified Data.UUID as U +import GHC.Generics + +import Shared.OpenId.Model.OpenId.OpenIdClientStyle + +data OpenIdClientSimple = OpenIdClientSimple + { uuid :: U.UUID + , name :: String + , url :: String + , style :: OpenIdClientStyle + } + deriving (Generic, Eq, Show) diff --git a/wizard-public/src/WizardLib/Public/Model/PersistentCommand/User/CreateOrUpdateUserCommand.hs b/wizard-public/src/WizardLib/Public/Model/PersistentCommand/User/CreateOrUpdateUserCommand.hs index 430d205e7..f418eccaf 100644 --- a/wizard-public/src/WizardLib/Public/Model/PersistentCommand/User/CreateOrUpdateUserCommand.hs +++ b/wizard-public/src/WizardLib/Public/Model/PersistentCommand/User/CreateOrUpdateUserCommand.hs @@ -12,7 +12,6 @@ data CreateOrUpdateUserCommand = CreateOrUpdateUserCommand , lastName :: String , email :: String , affiliation :: Maybe String - , sources :: [String] , uRole :: String , active :: Bool , imageUrl :: Maybe String diff --git a/wizard-public/src/WizardLib/Public/Model/Tenant/Config/TenantConfig.hs b/wizard-public/src/WizardLib/Public/Model/Tenant/Config/TenantConfig.hs index a17a16735..560106289 100644 --- a/wizard-public/src/WizardLib/Public/Model/Tenant/Config/TenantConfig.hs +++ b/wizard-public/src/WizardLib/Public/Model/Tenant/Config/TenantConfig.hs @@ -94,6 +94,7 @@ instance Eq TenantConfigFeatures where data TenantConfigMail = TenantConfigMail { tenantUuid :: U.UUID , configUuid :: Maybe U.UUID + , customTemplates :: Bool , createdAt :: UTCTime , updatedAt :: UTCTime } diff --git a/wizard-public/src/WizardLib/Public/Model/Tenant/Config/TenantConfigDM.hs b/wizard-public/src/WizardLib/Public/Model/Tenant/Config/TenantConfigDM.hs index 4e734688a..c822756e9 100644 --- a/wizard-public/src/WizardLib/Public/Model/Tenant/Config/TenantConfigDM.hs +++ b/wizard-public/src/WizardLib/Public/Model/Tenant/Config/TenantConfigDM.hs @@ -34,6 +34,7 @@ defaultMail = TenantConfigMail { tenantUuid = U.nil , configUuid = Nothing + , customTemplates = False , createdAt = dt' 2018 1 20 , updatedAt = dt' 2018 1 20 } diff --git a/wizard-public/src/WizardLib/Public/Model/User/UserOpenIdIdentity.hs b/wizard-public/src/WizardLib/Public/Model/User/UserOpenIdIdentity.hs new file mode 100644 index 000000000..e8dc2ea7b --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Model/User/UserOpenIdIdentity.hs @@ -0,0 +1,16 @@ +module WizardLib.Public.Model.User.UserOpenIdIdentity where + +import Data.Time +import qualified Data.UUID as U +import GHC.Generics + +data UserOpenIdIdentity = UserOpenIdIdentity + { uuid :: U.UUID + , externalId :: String + , externalLabel :: Maybe String + , userUuid :: U.UUID + , providerUuid :: U.UUID + , tenantUuid :: U.UUID + , createdAt :: UTCTime + } + deriving (Generic, Eq, Show) diff --git a/wizard-public/src/WizardLib/Public/Model/User/UserOpenIdIdentityList.hs b/wizard-public/src/WizardLib/Public/Model/User/UserOpenIdIdentityList.hs new file mode 100644 index 000000000..77e50a4e5 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Model/User/UserOpenIdIdentityList.hs @@ -0,0 +1,18 @@ +module WizardLib.Public.Model.User.UserOpenIdIdentityList where + +import Data.Time +import qualified Data.UUID as U +import GHC.Generics + +import Shared.OpenId.Model.OpenId.OpenIdClientStyle + +data UserOpenIdIdentityList = UserOpenIdIdentityList + { uuid :: U.UUID + , externalId :: String + , externalLabel :: Maybe String + , providerUuid :: U.UUID + , providerName :: String + , providerStyle :: OpenIdClientStyle + , createdAt :: UTCTime + } + deriving (Generic, Show) diff --git a/wizard-public/src/WizardLib/Public/Model/User/UserRegistrationPending.hs b/wizard-public/src/WizardLib/Public/Model/User/UserRegistrationPending.hs new file mode 100644 index 000000000..5fc98ad1f --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Model/User/UserRegistrationPending.hs @@ -0,0 +1,38 @@ +module WizardLib.Public.Model.User.UserRegistrationPending where + +import Data.Time +import qualified Data.UUID as U +import GHC.Generics + +data UserRegistrationPending serviceType = UserRegistrationPending + { uuid :: U.UUID + , hash :: String + , serviceType :: serviceType + , providerUuid :: U.UUID + , externalId :: String + , externalLabel :: Maybe String + , email :: Maybe String + , firstName :: Maybe String + , lastName :: Maybe String + , imageUrl :: Maybe String + , affiliation :: Maybe String + , tenantUuid :: U.UUID + , createdAt :: UTCTime + } + deriving (Show, Generic) + +instance Eq serviceType => Eq (UserRegistrationPending serviceType) where + a == b = + a.uuid == b.uuid + && a.hash == b.hash + && a.serviceType == b.serviceType + && a.providerUuid == b.providerUuid + && a.externalId == b.externalId + && a.externalLabel == b.externalLabel + && a.email == b.email + && a.firstName == b.firstName + && a.lastName == b.lastName + && a.imageUrl == b.imageUrl + && a.affiliation == b.affiliation + && a.tenantUuid == b.tenantUuid + && a.createdAt == b.createdAt diff --git a/wizard-public/src/WizardLib/Public/Service/OpenId/Client/Definition/OpenIdClientDefinitionMapper.hs b/wizard-public/src/WizardLib/Public/Service/OpenId/Client/Definition/OpenIdClientDefinitionMapper.hs new file mode 100644 index 000000000..b290b280a --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Service/OpenId/Client/Definition/OpenIdClientDefinitionMapper.hs @@ -0,0 +1,72 @@ +module WizardLib.Public.Service.OpenId.Client.Definition.OpenIdClientDefinitionMapper where + +import Data.Time +import qualified Data.UUID as U + +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeDTO +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailDTO +import WizardLib.Public.Model.OpenId.OpenIdClient +import WizardLib.Public.Model.OpenId.OpenIdClientSimple + +toSimple :: OpenIdClient -> OpenIdClientSimple +toSimple openIdClient = + OpenIdClientSimple + { uuid = openIdClient.uuid + , name = openIdClient.name + , url = openIdClient.url + , style = openIdClient.style + } + +toDetailDTO :: OpenIdClient -> OpenIdClientDetailDTO +toDetailDTO openIdClient = + OpenIdClientDetailDTO + { uuid = openIdClient.uuid + , name = openIdClient.name + , url = openIdClient.url + , clientId = openIdClient.clientId + , clientSecret = openIdClient.clientSecret + , parameters = openIdClient.parameters + , style = openIdClient.style + , registrationEnabled = openIdClient.registrationEnabled + , scopeProfile = openIdClient.scopeProfile + , scopeEmail = openIdClient.scopeEmail + , tenantUuid = openIdClient.tenantUuid + , createdAt = openIdClient.createdAt + , updatedAt = openIdClient.updatedAt + } + +fromCreateDTO :: OpenIdClientChangeDTO -> U.UUID -> U.UUID -> UTCTime -> OpenIdClient +fromCreateDTO reqDto uuid tenantUuid now = + OpenIdClient + { uuid = uuid + , name = reqDto.name + , url = reqDto.url + , clientId = reqDto.clientId + , clientSecret = reqDto.clientSecret + , parameters = reqDto.parameters + , style = reqDto.style + , registrationEnabled = reqDto.registrationEnabled + , scopeProfile = reqDto.scopeProfile + , scopeEmail = reqDto.scopeEmail + , tenantUuid = tenantUuid + , createdAt = now + , updatedAt = now + } + +fromChangeDTO :: OpenIdClient -> OpenIdClientChangeDTO -> UTCTime -> OpenIdClient +fromChangeDTO openIdClient reqDto now = + OpenIdClient + { uuid = openIdClient.uuid + , name = reqDto.name + , url = reqDto.url + , clientId = reqDto.clientId + , clientSecret = reqDto.clientSecret + , parameters = reqDto.parameters + , style = reqDto.style + , registrationEnabled = reqDto.registrationEnabled + , scopeProfile = reqDto.scopeProfile + , scopeEmail = reqDto.scopeEmail + , tenantUuid = openIdClient.tenantUuid + , createdAt = openIdClient.createdAt + , updatedAt = now + } diff --git a/wizard-public/src/WizardLib/Public/Service/PersistentCommand/PersistentCommandService.hs b/wizard-public/src/WizardLib/Public/Service/PersistentCommand/PersistentCommandService.hs new file mode 100644 index 000000000..64d351d1f --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Service/PersistentCommand/PersistentCommandService.hs @@ -0,0 +1,30 @@ +module WizardLib.Public.Service.PersistentCommand.PersistentCommandService where + +import Control.Monad (void) +import Control.Monad.Reader (ask) +import Data.Foldable (traverse_) +import qualified Data.List as L +import qualified Data.UUID as U +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.ToField + +import Shared.Common.Model.Config.ServerConfig +import Shared.Common.Model.Context.AppContext +import Shared.Common.Util.Logger +import Shared.PersistentCommand.Database.DAO.PersistentCommand.PersistentCommandDAO +import Shared.PersistentCommand.Model.PersistentCommand.PersistentCommandSimple +import WizardLib.Public.Database.DAO.PersistentCommand.PersistentCommandDAO + +retryPersistentCommandsForLambda :: AppContextC s sc m => m () +retryPersistentCommandsForLambda = do + context <- ask + let components = fmap (\lf -> lf.component) context.serverConfig'.persistentCommand'.lambdaFunctions + persistentCommands <- findPersistentCommandsForLambdaByStates components + traverse_ retryPersistentCommandForLambda persistentCommands + +retryPersistentCommandForLambda :: (Show identity, FromField identity, ToField identity, AppContextC s sc m) => PersistentCommandSimple identity -> m () +retryPersistentCommandForLambda command = do + context <- ask + case L.find (\lf -> lf.component == command.component) context.serverConfig'.persistentCommand'.lambdaFunctions of + Just lf -> void $ invokeLambdaFunction command lf + Nothing -> logWarnI _CMP_DATABASE (f' "No lambda function found for persistent command '%s'" [U.toString command.uuid]) diff --git a/wizard-public/src/WizardLib/Public/Service/User/UserOpenIdIdentityMapper.hs b/wizard-public/src/WizardLib/Public/Service/User/UserOpenIdIdentityMapper.hs new file mode 100644 index 000000000..439a28fac --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Service/User/UserOpenIdIdentityMapper.hs @@ -0,0 +1,45 @@ +module WizardLib.Public.Service.User.UserOpenIdIdentityMapper where + +import Data.Time +import qualified Data.UUID as U + +import WizardLib.Public.Api.Resource.User.UserOpenIdIdentityDTO +import WizardLib.Public.Model.User.UserOpenIdIdentity +import WizardLib.Public.Model.User.UserOpenIdIdentityList +import WizardLib.Public.Model.User.UserRegistrationPending + +toDTO :: UserOpenIdIdentityList -> UserOpenIdIdentityDTO +toDTO entity = + UserOpenIdIdentityDTO + { uuid = entity.uuid + , externalId = entity.externalId + , externalLabel = entity.externalLabel + , providerUuid = entity.providerUuid + , providerName = entity.providerName + , providerStyle = entity.providerStyle + , createdAt = entity.createdAt + } + +fromCreate :: U.UUID -> String -> Maybe String -> U.UUID -> U.UUID -> U.UUID -> UTCTime -> UserOpenIdIdentity +fromCreate uuid externalId mExternalLabel userUuid providerUuid tenantUuid now = + UserOpenIdIdentity + { uuid = uuid + , externalId = externalId + , externalLabel = mExternalLabel + , userUuid = userUuid + , providerUuid = providerUuid + , tenantUuid = tenantUuid + , createdAt = now + } + +fromPending :: U.UUID -> UserRegistrationPending serviceType -> U.UUID -> UTCTime -> UserOpenIdIdentity +fromPending uuid pending userUuid now = + UserOpenIdIdentity + { uuid = uuid + , externalId = pending.externalId + , externalLabel = pending.externalLabel + , userUuid = userUuid + , providerUuid = pending.providerUuid + , tenantUuid = pending.tenantUuid + , createdAt = now + } diff --git a/wizard-public/src/WizardLib/Public/Service/User/UserRegistrationPendingService.hs b/wizard-public/src/WizardLib/Public/Service/User/UserRegistrationPendingService.hs new file mode 100644 index 000000000..86ecb6848 --- /dev/null +++ b/wizard-public/src/WizardLib/Public/Service/User/UserRegistrationPendingService.hs @@ -0,0 +1,80 @@ +module WizardLib.Public.Service.User.UserRegistrationPendingService where + +import Control.Monad (void) +import Control.Monad.Reader (asks, liftIO) +import Data.Time +import qualified Data.UUID as U +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.ToField + +import Shared.Common.Database.DAO.Common +import Shared.Common.Model.Context.AppContext +import Shared.Common.Util.Date (nominalDayInSeconds) +import Shared.Common.Util.Logger +import Shared.Common.Util.Uuid +import WizardLib.Public.Database.DAO.User.UserRegistrationPendingDAO +import WizardLib.Public.Model.User.UserRegistrationPending + +upsertPendingExternalRegistration + :: ( AppContextC s sc m + , ToField serviceType + , FromField serviceType + , Show serviceType + ) + => serviceType + -> U.UUID + -> String + -> Maybe String + -> Maybe String + -> Maybe String + -> Maybe String + -> Maybe String + -> Maybe String + -> m (UserRegistrationPending serviceType) +upsertPendingExternalRegistration serviceType providerUuid externalId mExternalLabel mEmail mFirstName mLastName mImageUrl mAffiliation = + runInTransaction logInfoI logWarnI $ do + tenantUuid <- asks (.tenantUuid') + mExisting <- + findUserRegistrationPendingByServiceTypeAndExternalIdAndProviderUuid' serviceType externalId providerUuid + case mExisting of + Just existing -> do + let updated = + existing + { externalLabel = mExternalLabel + , email = mEmail + , firstName = mFirstName + , lastName = mLastName + , imageUrl = mImageUrl + , affiliation = mAffiliation + } + void $ updateUserRegistrationPendingByUuid updated + return updated + Nothing -> do + uuid <- liftIO generateUuid + hashUuid <- liftIO generateUuid + now <- liftIO getCurrentTime + let pending = + UserRegistrationPending + { uuid = uuid + , hash = U.toString hashUuid + , serviceType = serviceType + , providerUuid = providerUuid + , externalId = externalId + , externalLabel = mExternalLabel + , email = mEmail + , firstName = mFirstName + , lastName = mLastName + , imageUrl = mImageUrl + , affiliation = mAffiliation + , tenantUuid = tenantUuid + , createdAt = now + } + void $ insertUserRegistrationPending pending + return pending + +cleanUserRegistrationPending :: AppContextC s sc m => m () +cleanUserRegistrationPending = do + now <- liftIO getCurrentTime + let timeDelta = realToFrac . toInteger $ nominalDayInSeconds * (-1) + let dayBefore = addUTCTime timeDelta now + void $ deleteUserRegistrationPendingsOlderThan dayBefore diff --git a/wizard-server/config/application-test.yml.example b/wizard-server/config/application-test.yml.example index fdf909493..5071f36d9 100644 --- a/wizard-server/config/application-test.yml.example +++ b/wizard-server/config/application-test.yml.example @@ -64,9 +64,6 @@ database: s3: url: http://localhost:9000 -jwt: - expiration: 9999 - registry: url: https://api.registry-test.ds-wizard.org clientUrl: https://registry-test.ds-wizard.org diff --git a/wizard-server/package.yaml b/wizard-server/package.yaml index f2ff774ab..90006e243 100644 --- a/wizard-server/package.yaml +++ b/wizard-server/package.yaml @@ -1,5 +1,5 @@ name: wizard-server -version: '4.30.0' +version: '4.31.0' synopsis: Engine Wizard description: Engine Wizard category: Web diff --git a/wizard-server/src/Wizard/Api/Handler/ActionKey/Api.hs b/wizard-server/src/Wizard/Api/Handler/ActionKey/Api.hs deleted file mode 100644 index 8ef13bce8..000000000 --- a/wizard-server/src/Wizard/Api/Handler/ActionKey/Api.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Wizard.Api.Handler.ActionKey.Api where - -import Servant -import Servant.Swagger.Tags - -import Wizard.Api.Handler.ActionKey.List_POST -import Wizard.Model.Context.BaseContext - -type ActionKeyAPI = - Tags "Action Key" - :> List_POST - -actionKeyApi :: Proxy ActionKeyAPI -actionKeyApi = Proxy - -actionKeyServer :: ServerT ActionKeyAPI BaseContextM -actionKeyServer = list_POST diff --git a/wizard-server/src/Wizard/Api/Handler/Api.hs b/wizard-server/src/Wizard/Api/Handler/Api.hs index 1b2e1ca47..0a652adbe 100644 --- a/wizard-server/src/Wizard/Api/Handler/Api.hs +++ b/wizard-server/src/Wizard/Api/Handler/Api.hs @@ -2,10 +2,8 @@ module Wizard.Api.Handler.Api where import Servant -import Wizard.Api.Handler.ActionKey.Api import Wizard.Api.Handler.ApiKey.Api import Wizard.Api.Handler.AppKey.Api -import Wizard.Api.Handler.Auth.Api import Wizard.Api.Handler.Config.Api import Wizard.Api.Handler.Dev.Api import Wizard.Api.Handler.Document.Api @@ -23,6 +21,7 @@ import Wizard.Api.Handler.KnowledgeModelEditor.Api import Wizard.Api.Handler.KnowledgeModelPackage.Api import Wizard.Api.Handler.KnowledgeModelSecret.Api import Wizard.Api.Handler.Locale.Api +import Wizard.Api.Handler.OpenIdClient.Api import Wizard.Api.Handler.PersistentCommand.Api import Wizard.Api.Handler.Prefab.Api import Wizard.Api.Handler.Project.Api @@ -34,14 +33,14 @@ import Wizard.Api.Handler.Tenant.Api import Wizard.Api.Handler.Token.Api import Wizard.Api.Handler.TypeHint.Api import Wizard.Api.Handler.User.Api +import Wizard.Api.Handler.UserEmailLink.Api import Wizard.Api.Handler.UserGroup.Api import Wizard.Model.Context.BaseContext type ApplicationAPI = - ActionKeyAPI + UserEmailLinkAPI :<|> ApiKeyAPI :<|> AppKeyAPI - :<|> AuthAPI :<|> ConfigAPI :<|> DevAPI :<|> DocumentTemplateAPI @@ -59,6 +58,7 @@ type ApplicationAPI = :<|> KnowledgeModelPackageAPI :<|> KnowledgeModelSecretAPI :<|> LocaleAPI + :<|> OpenIdClientAPI :<|> PersistentCommandAPI :<|> PrefabAPI :<|> ProjectAPI @@ -77,10 +77,9 @@ applicationApi = Proxy applicationServer :: ServerT ApplicationAPI BaseContextM applicationServer = - actionKeyServer + userEmailLinkServer :<|> apiKeyServer :<|> appKeyServer - :<|> authServer :<|> configServer :<|> devServer :<|> documentTemplateServer @@ -98,6 +97,7 @@ applicationServer = :<|> knowledgeModelPackageServer :<|> knowledgeModelSecretServer :<|> localeServer + :<|> openIdClientServer :<|> persistentCommandServer :<|> prefabServer :<|> projectServer diff --git a/wizard-server/src/Wizard/Api/Handler/Auth/Api.hs b/wizard-server/src/Wizard/Api/Handler/Auth/Api.hs deleted file mode 100644 index 9a7a8dc9d..000000000 --- a/wizard-server/src/Wizard/Api/Handler/Auth/Api.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Wizard.Api.Handler.Auth.Api where - -import Servant -import Servant.Swagger.Tags - -import Wizard.Api.Handler.Auth.Detail_Callback_GET -import Wizard.Api.Handler.Auth.Detail_Consents_POST -import Wizard.Api.Handler.Auth.Detail_GET -import Wizard.Api.Handler.Auth.Detail_Logout_GET -import Wizard.Model.Context.BaseContext - -type AuthAPI = - Tags "Auth" - :> ( Detail_GET - :<|> Detail_Callback_GET - :<|> Detail_Consents_POST - :<|> Detail_Logout_GET - ) - -authApi :: Proxy AuthAPI -authApi = Proxy - -authServer :: ServerT AuthAPI BaseContextM -authServer = detail_GET :<|> detail_callback_GET :<|> detail_consents_POST :<|> detail_logout_GET diff --git a/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Api.hs b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Api.hs new file mode 100644 index 000000000..7baed5127 --- /dev/null +++ b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Api.hs @@ -0,0 +1,40 @@ +module Wizard.Api.Handler.OpenIdClient.Api where + +import Servant +import Servant.Swagger.Tags + +import Wizard.Api.Handler.OpenIdClient.Detail_DELETE +import Wizard.Api.Handler.OpenIdClient.Detail_GET +import Wizard.Api.Handler.OpenIdClient.Detail_Logout_GET +import Wizard.Api.Handler.OpenIdClient.Detail_PUT +import Wizard.Api.Handler.OpenIdClient.Detail_Request_GET +import Wizard.Api.Handler.OpenIdClient.Detail_Response_GET +import Wizard.Api.Handler.OpenIdClient.List_GET +import Wizard.Api.Handler.OpenIdClient.List_POST +import Wizard.Model.Context.BaseContext + +type OpenIdClientAPI = + Tags "OpenID Client" + :> ( List_GET + :<|> List_POST + :<|> Detail_GET + :<|> Detail_PUT + :<|> Detail_DELETE + :<|> Detail_Request_GET + :<|> Detail_Response_GET + :<|> Detail_Logout_GET + ) + +openIdClientApi :: Proxy OpenIdClientAPI +openIdClientApi = Proxy + +openIdClientServer :: ServerT OpenIdClientAPI BaseContextM +openIdClientServer = + list_GET + :<|> list_POST + :<|> detail_GET + :<|> detail_PUT + :<|> detail_DELETE + :<|> detail_request_GET + :<|> detail_response_GET + :<|> detail_logout_GET diff --git a/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_DELETE.hs b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_DELETE.hs new file mode 100644 index 000000000..fcd0c83f2 --- /dev/null +++ b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_DELETE.hs @@ -0,0 +1,25 @@ +module Wizard.Api.Handler.OpenIdClient.Detail_DELETE where + +import qualified Data.UUID as U +import Servant + +import Shared.Common.Api.Handler.Common +import Shared.Common.Model.Context.TransactionState +import Wizard.Api.Handler.Common +import Wizard.Model.Context.BaseContext +import Wizard.Service.OpenId.Client.Definition.OpenIdClientDefinitionService + +type Detail_DELETE = + Header "Authorization" String + :> Header "Host" String + :> "open-id-clients" + :> Capture "uuid" U.UUID + :> Verb DELETE 204 '[SafeJSON] (Headers '[Header "x-trace-uuid" String] NoContent) + +detail_DELETE :: Maybe String -> Maybe String -> U.UUID -> BaseContextM (Headers '[Header "x-trace-uuid" String] NoContent) +detail_DELETE mTokenHeader mServerUrl uuid = + getAuthServiceExecutor mTokenHeader mServerUrl $ \runInAuthService -> + runInAuthService Transactional $ + addTraceUuidHeader =<< do + deleteOpenIdClientDefinition uuid + return NoContent diff --git a/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_GET.hs b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_GET.hs new file mode 100644 index 000000000..3b8aa8505 --- /dev/null +++ b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_GET.hs @@ -0,0 +1,25 @@ +module Wizard.Api.Handler.OpenIdClient.Detail_GET where + +import qualified Data.UUID as U +import Servant + +import Shared.Common.Api.Handler.Common +import Shared.Common.Model.Context.TransactionState +import Wizard.Api.Handler.Common +import Wizard.Model.Context.BaseContext +import Wizard.Service.OpenId.Client.Definition.OpenIdClientDefinitionService +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailDTO +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailJM () + +type Detail_GET = + Header "Authorization" String + :> Header "Host" String + :> "open-id-clients" + :> Capture "uuid" U.UUID + :> Get '[SafeJSON] (Headers '[Header "x-trace-uuid" String] OpenIdClientDetailDTO) + +detail_GET :: Maybe String -> Maybe String -> U.UUID -> BaseContextM (Headers '[Header "x-trace-uuid" String] OpenIdClientDetailDTO) +detail_GET mTokenHeader mServerUrl uuid = + getAuthServiceExecutor mTokenHeader mServerUrl $ \runInAuthService -> + runInAuthService NoTransaction $ + addTraceUuidHeader =<< getOpenIdClientDefinitionByUuid uuid diff --git a/wizard-server/src/Wizard/Api/Handler/Auth/Detail_Logout_GET.hs b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_Logout_GET.hs similarity index 70% rename from wizard-server/src/Wizard/Api/Handler/Auth/Detail_Logout_GET.hs rename to wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_Logout_GET.hs index bdc9e230b..886f9773b 100644 --- a/wizard-server/src/Wizard/Api/Handler/Auth/Detail_Logout_GET.hs +++ b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_Logout_GET.hs @@ -1,5 +1,6 @@ -module Wizard.Api.Handler.Auth.Detail_Logout_GET where +module Wizard.Api.Handler.OpenIdClient.Detail_Logout_GET where +import qualified Data.UUID as U import Servant import Shared.Common.Api.Handler.Common @@ -10,15 +11,15 @@ import Wizard.Service.UserToken.Login.LoginService type Detail_Logout_GET = Header "Host" String - :> "auth" - :> Capture "id" String + :> "open-id-clients" + :> Capture "uuid" U.UUID :> "logout" :> QueryParam "sid" String :> Verb GET 204 '[SafeJSON] (Headers '[Header "x-trace-uuid" String] NoContent) detail_logout_GET - :: Maybe String -> String -> Maybe String -> BaseContextM (Headers '[Header "x-trace-uuid" String] NoContent) -detail_logout_GET mServerUrl authId mSid = + :: Maybe String -> U.UUID -> Maybe String -> BaseContextM (Headers '[Header "x-trace-uuid" String] NoContent) +detail_logout_GET mServerUrl _providerUuid mSid = runInUnauthService mServerUrl Transactional $ addTraceUuidHeader =<< do deleteLoginTokenBySessionState mSid diff --git a/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_PUT.hs b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_PUT.hs new file mode 100644 index 000000000..10b4ee950 --- /dev/null +++ b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_PUT.hs @@ -0,0 +1,33 @@ +module Wizard.Api.Handler.OpenIdClient.Detail_PUT where + +import qualified Data.UUID as U +import Servant + +import Shared.Common.Api.Handler.Common +import Shared.Common.Model.Context.TransactionState +import Wizard.Api.Handler.Common +import Wizard.Model.Context.BaseContext +import Wizard.Service.OpenId.Client.Definition.OpenIdClientDefinitionService +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeDTO +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeJM () +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailDTO +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailJM () + +type Detail_PUT = + Header "Authorization" String + :> Header "Host" String + :> ReqBody '[SafeJSON] OpenIdClientChangeDTO + :> "open-id-clients" + :> Capture "uuid" U.UUID + :> Put '[SafeJSON] (Headers '[Header "x-trace-uuid" String] OpenIdClientDetailDTO) + +detail_PUT + :: Maybe String + -> Maybe String + -> OpenIdClientChangeDTO + -> U.UUID + -> BaseContextM (Headers '[Header "x-trace-uuid" String] OpenIdClientDetailDTO) +detail_PUT mTokenHeader mServerUrl reqDto uuid = + getAuthServiceExecutor mTokenHeader mServerUrl $ \runInAuthService -> + runInAuthService Transactional $ + addTraceUuidHeader =<< modifyOpenIdClientDefinition uuid reqDto diff --git a/wizard-server/src/Wizard/Api/Handler/Auth/Detail_GET.hs b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_Request_GET.hs similarity index 64% rename from wizard-server/src/Wizard/Api/Handler/Auth/Detail_GET.hs rename to wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_Request_GET.hs index 9b18ecf88..29961bd4f 100644 --- a/wizard-server/src/Wizard/Api/Handler/Auth/Detail_GET.hs +++ b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_Request_GET.hs @@ -1,5 +1,6 @@ -module Wizard.Api.Handler.Auth.Detail_GET where +module Wizard.Api.Handler.OpenIdClient.Detail_Request_GET where +import qualified Data.UUID as U import Servant import Shared.Common.Api.Handler.Common @@ -8,22 +9,23 @@ import Wizard.Api.Handler.Common import Wizard.Model.Context.BaseContext import Wizard.Service.OpenId.Client.Flow.OpenIdClientFlowService -type Detail_GET = +type Detail_Request_GET = Header "Host" String - :> "auth" - :> Capture "id" String + :> "open-id-clients" + :> Capture "uuid" U.UUID + :> "request" :> QueryParam "flow" String :> QueryParam "clientUrl" String :> Get '[SafeJSON] (Headers '[Header "x-trace-uuid" String] NoContent) -detail_GET +detail_request_GET :: Maybe String - -> String + -> U.UUID -> Maybe String -> Maybe String -> BaseContextM (Headers '[Header "x-trace-uuid" String] NoContent) -detail_GET mServerUrl authId mFlow mClientUrl = +detail_request_GET mServerUrl providerUuid mFlow mClientUrl = runInUnauthService mServerUrl NoTransaction $ addTraceUuidHeader =<< do - createAuthenticationUrl authId mFlow mClientUrl + createAuthenticationUrl providerUuid mFlow mClientUrl return NoContent diff --git a/wizard-server/src/Wizard/Api/Handler/Auth/Detail_Callback_GET.hs b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_Response_GET.hs similarity index 54% rename from wizard-server/src/Wizard/Api/Handler/Auth/Detail_Callback_GET.hs rename to wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_Response_GET.hs index 8a1b370cb..f8a0bc676 100644 --- a/wizard-server/src/Wizard/Api/Handler/Auth/Detail_Callback_GET.hs +++ b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/Detail_Response_GET.hs @@ -1,5 +1,7 @@ -module Wizard.Api.Handler.Auth.Detail_Callback_GET where +module Wizard.Api.Handler.OpenIdClient.Detail_Response_GET where +import Data.Maybe (isJust) +import qualified Data.UUID as U import Servant import Shared.Common.Api.Handler.Common @@ -9,12 +11,13 @@ import Wizard.Model.Context.BaseContext import Wizard.Service.OpenId.Client.Flow.OpenIdClientFlowService import WizardLib.Public.Api.Resource.UserToken.UserTokenDTO -type Detail_Callback_GET = - Header "Host" String +type Detail_Response_GET = + Header "Authorization" String + :> Header "Host" String :> Header "User-Agent" String - :> "auth" - :> Capture "id" String - :> "callback" + :> "open-id-clients" + :> Capture "uuid" U.UUID + :> "response" :> QueryParam "clientUrl" String :> QueryParam "error" String :> QueryParam "code" String @@ -23,10 +26,11 @@ type Detail_Callback_GET = :> QueryParam "session_state" String :> Get '[SafeJSON] (Headers '[Header "x-trace-uuid" String] UserTokenDTO) -detail_callback_GET +detail_response_GET :: Maybe String -> Maybe String - -> String + -> Maybe String + -> U.UUID -> Maybe String -> Maybe String -> Maybe String @@ -34,6 +38,7 @@ detail_callback_GET -> Maybe String -> Maybe String -> BaseContextM (Headers '[Header "x-trace-uuid" String] UserTokenDTO) -detail_callback_GET mServerUrl mUserAgent authId mClientUrl mError mCode mNonce mIdToken mSessionState = - runInUnauthService mServerUrl Transactional $ - addTraceUuidHeader =<< loginUser authId mClientUrl mError mCode mNonce mIdToken mUserAgent mSessionState +detail_response_GET mTokenHeader mServerUrl mUserAgent providerUuid mClientUrl mError mCode mNonce mIdToken mSessionState = + getMaybeAuthServiceExecutor mTokenHeader mServerUrl $ \runInAuthService -> + runInAuthService Transactional $ + addTraceUuidHeader =<< loginUserOrLinkIdentity (isJust mTokenHeader) providerUuid mClientUrl mError mCode mNonce mIdToken mUserAgent mSessionState diff --git a/wizard-server/src/Wizard/Api/Handler/OpenIdClient/List_GET.hs b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/List_GET.hs new file mode 100644 index 000000000..f59876c8a --- /dev/null +++ b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/List_GET.hs @@ -0,0 +1,23 @@ +module Wizard.Api.Handler.OpenIdClient.List_GET where + +import Servant + +import Shared.Common.Api.Handler.Common +import Shared.Common.Model.Context.TransactionState +import Wizard.Api.Handler.Common +import Wizard.Model.Context.BaseContext +import Wizard.Service.OpenId.Client.Definition.OpenIdClientDefinitionService +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientSimpleJM () +import WizardLib.Public.Model.OpenId.OpenIdClientSimple + +type List_GET = + Header "Authorization" String + :> Header "Host" String + :> "open-id-clients" + :> Get '[SafeJSON] (Headers '[Header "x-trace-uuid" String] [OpenIdClientSimple]) + +list_GET :: Maybe String -> Maybe String -> BaseContextM (Headers '[Header "x-trace-uuid" String] [OpenIdClientSimple]) +list_GET mTokenHeader mServerUrl = + getAuthServiceExecutor mTokenHeader mServerUrl $ \runInAuthService -> + runInAuthService NoTransaction $ + addTraceUuidHeader =<< getOpenIdClientDefinitions diff --git a/wizard-server/src/Wizard/Api/Handler/OpenIdClient/List_POST.hs b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/List_POST.hs new file mode 100644 index 000000000..2d963ba38 --- /dev/null +++ b/wizard-server/src/Wizard/Api/Handler/OpenIdClient/List_POST.hs @@ -0,0 +1,30 @@ +module Wizard.Api.Handler.OpenIdClient.List_POST where + +import Servant + +import Shared.Common.Api.Handler.Common +import Shared.Common.Model.Context.TransactionState +import Wizard.Api.Handler.Common +import Wizard.Model.Context.BaseContext +import Wizard.Service.OpenId.Client.Definition.OpenIdClientDefinitionService +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeDTO +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeJM () +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailDTO +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailJM () + +type List_POST = + Header "Authorization" String + :> Header "Host" String + :> ReqBody '[SafeJSON] OpenIdClientChangeDTO + :> "open-id-clients" + :> Post '[SafeJSON] (Headers '[Header "x-trace-uuid" String] OpenIdClientDetailDTO) + +list_POST + :: Maybe String + -> Maybe String + -> OpenIdClientChangeDTO + -> BaseContextM (Headers '[Header "x-trace-uuid" String] OpenIdClientDetailDTO) +list_POST mTokenHeader mServerUrl reqDto = + getAuthServiceExecutor mTokenHeader mServerUrl $ \runInAuthService -> + runInAuthService Transactional $ + addTraceUuidHeader =<< createOpenIdClientDefinition reqDto diff --git a/wizard-server/src/Wizard/Api/Handler/Swagger/Api.hs b/wizard-server/src/Wizard/Api/Handler/Swagger/Api.hs index 7e19693ac..3d9f32114 100644 --- a/wizard-server/src/Wizard/Api/Handler/Swagger/Api.hs +++ b/wizard-server/src/Wizard/Api/Handler/Swagger/Api.hs @@ -27,7 +27,6 @@ import Shared.PersistentCommand.Api.Resource.PersistentCommand.PersistentCommand import Shared.PersistentCommand.Api.Resource.PersistentCommand.PersistentCommandSM () import Shared.Prefab.Api.Resource.Prefab.PrefabSM () import Wizard.Api.Handler.Api -import Wizard.Api.Resource.ActionKey.ActionKeyTypeSM () import Wizard.Api.Resource.Auth.AuthConsentSM () import Wizard.Api.Resource.Common.PageSM () import Wizard.Api.Resource.Config.ClientConfigSM () @@ -124,17 +123,23 @@ import Wizard.Api.Resource.User.UserSM () import Wizard.Api.Resource.User.UserStateSM () import Wizard.Api.Resource.User.UserSubmissionPropListSM () import Wizard.Api.Resource.User.UserSubmissionPropSM () +import Wizard.Api.Resource.UserEmailLink.UserEmailLinkTypeSM () import Wizard.Api.Resource.UserToken.ApiKeyCreateSM () import Wizard.Api.Resource.UserToken.AppKeyCreateSM () import Wizard.Api.Resource.UserToken.UserTokenListSM () import Wizard.Api.Resource.Websocket.ProjectMessageSM () import Wizard.Api.Resource.Websocket.WebsocketSM () +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeSM () +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailSM () +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientSimpleSM () import WizardLib.Public.Api.Resource.PersistentCommand.PersistentCommandListSM () import WizardLib.Public.Api.Resource.TemporaryFile.TemporaryFileSM () import WizardLib.Public.Api.Resource.Tenant.Limit.TenantLimitBundleChangeSM () import WizardLib.Public.Api.Resource.Tenant.Usage.WizardUsageSM () import WizardLib.Public.Api.Resource.User.Group.UserGroupDetailSM () +import WizardLib.Public.Api.Resource.User.UserFromExternalSM () import WizardLib.Public.Api.Resource.User.UserLocaleSM () +import WizardLib.Public.Api.Resource.User.UserOpenIdIdentitySM () import WizardLib.Public.Api.Resource.UserToken.LoginSM () import WizardLib.Public.Api.Resource.UserToken.UserTokenSM () @@ -148,7 +153,7 @@ swagger = s._swaggerInfo { _infoTitle = "Wizard API" , _infoDescription = Just "API specification for Wizard" - , _infoVersion = "4.30.0" + , _infoVersion = "4.31.0" , _infoLicense = Just $ License diff --git a/wizard-server/src/Wizard/Api/Handler/User/Api.hs b/wizard-server/src/Wizard/Api/Handler/User/Api.hs index 7e812fedc..36500f947 100644 --- a/wizard-server/src/Wizard/Api/Handler/User/Api.hs +++ b/wizard-server/src/Wizard/Api/Handler/User/Api.hs @@ -3,18 +3,23 @@ module Wizard.Api.Handler.User.Api where import Servant import Servant.Swagger.Tags +import Wizard.Api.Handler.User.Detail_Current_Identity_DELETE import Wizard.Api.Handler.User.Detail_DELETE import Wizard.Api.Handler.User.Detail_GET import Wizard.Api.Handler.User.Detail_PUT import Wizard.Api.Handler.User.Detail_Password_PUT import Wizard.Api.Handler.User.Detail_State_PUT +import Wizard.Api.Handler.User.List_Consents_POST +import Wizard.Api.Handler.User.List_Current_Email_PUT import Wizard.Api.Handler.User.List_Current_GET +import Wizard.Api.Handler.User.List_Current_Identities_GET import Wizard.Api.Handler.User.List_Current_Locale_GET import Wizard.Api.Handler.User.List_Current_Locale_PUT import Wizard.Api.Handler.User.List_Current_PUT import Wizard.Api.Handler.User.List_Current_Password_PUT import Wizard.Api.Handler.User.List_Current_Submission_Props_GET import Wizard.Api.Handler.User.List_Current_Submission_Props_PUT +import Wizard.Api.Handler.User.List_From_External_POST import Wizard.Api.Handler.User.List_GET import Wizard.Api.Handler.User.List_POST import Wizard.Api.Handler.User.List_Suggestions_GET @@ -28,6 +33,8 @@ type UserAPI = :> ( List_GET :<|> List_Suggestions_GET :<|> List_POST + :<|> List_Consents_POST + :<|> List_From_External_POST :<|> List_Current_GET :<|> List_Current_PUT :<|> List_Current_Submission_Props_GET @@ -35,11 +42,14 @@ type UserAPI = :<|> List_Current_Password_PUT :<|> List_Current_Locale_GET :<|> List_Current_Locale_PUT + :<|> List_Current_Email_PUT + :<|> List_Current_Identities_GET :<|> Detail_GET :<|> Detail_PUT :<|> Detail_Password_PUT :<|> Detail_State_PUT :<|> Detail_DELETE + :<|> Detail_Current_Identity_DELETE :<|> NewsAPI :<|> PluginSettingsAPI :<|> TourAPI @@ -53,6 +63,8 @@ userServer = list_GET :<|> list_suggestions_GET :<|> list_POST + :<|> list_consents_POST + :<|> list_from_external_POST :<|> list_current_GET :<|> list_current_PUT :<|> list_current_submission_props_GET @@ -60,11 +72,14 @@ userServer = :<|> list_current_password_PUT :<|> list_current_locale_GET :<|> list_current_locale_PUT + :<|> list_current_email_PUT + :<|> list_current_identities_GET :<|> detail_GET :<|> detail_PUT :<|> detail_password_PUT :<|> detail_state_PUT :<|> detail_DELETE + :<|> detail_current_identity_DELETE :<|> newsServer :<|> pluginSettingsServer :<|> tourServer diff --git a/wizard-server/src/Wizard/Api/Handler/User/Detail_Current_Identity_DELETE.hs b/wizard-server/src/Wizard/Api/Handler/User/Detail_Current_Identity_DELETE.hs new file mode 100644 index 000000000..9b3182666 --- /dev/null +++ b/wizard-server/src/Wizard/Api/Handler/User/Detail_Current_Identity_DELETE.hs @@ -0,0 +1,31 @@ +module Wizard.Api.Handler.User.Detail_Current_Identity_DELETE where + +import qualified Data.UUID as U +import Servant + +import Shared.Common.Api.Handler.Common +import Shared.Common.Model.Context.TransactionState +import Wizard.Api.Handler.Common +import Wizard.Model.Context.BaseContext +import Wizard.Service.User.ExternalIdentity.UserExternalIdentityService + +type Detail_Current_Identity_DELETE = + Header "Authorization" String + :> Header "Host" String + :> "users" + :> "current" + :> "identities" + :> Capture "uuid" U.UUID + :> Verb DELETE 204 '[SafeJSON] (Headers '[Header "x-trace-uuid" String] NoContent) + +detail_current_identity_DELETE + :: Maybe String + -> Maybe String + -> U.UUID + -> BaseContextM (Headers '[Header "x-trace-uuid" String] NoContent) +detail_current_identity_DELETE mTokenHeader mServerUrl uuid = + getAuthServiceExecutor mTokenHeader mServerUrl $ \runInAuthService -> + runInAuthService Transactional $ + addTraceUuidHeader =<< do + deleteUserIdentity uuid + return NoContent diff --git a/wizard-server/src/Wizard/Api/Handler/Auth/Detail_Consents_POST.hs b/wizard-server/src/Wizard/Api/Handler/User/List_Consents_POST.hs similarity index 77% rename from wizard-server/src/Wizard/Api/Handler/Auth/Detail_Consents_POST.hs rename to wizard-server/src/Wizard/Api/Handler/User/List_Consents_POST.hs index 3a7429d0d..045cccdaa 100644 --- a/wizard-server/src/Wizard/Api/Handler/Auth/Detail_Consents_POST.hs +++ b/wizard-server/src/Wizard/Api/Handler/User/List_Consents_POST.hs @@ -1,4 +1,4 @@ -module Wizard.Api.Handler.Auth.Detail_Consents_POST where +module Wizard.Api.Handler.User.List_Consents_POST where import Servant @@ -10,21 +10,19 @@ import Wizard.Model.Context.BaseContext import Wizard.Service.User.UserService import WizardLib.Public.Api.Resource.UserToken.UserTokenDTO -type Detail_Consents_POST = +type List_Consents_POST = Header "Host" String :> Header "User-Agent" String :> ReqBody '[SafeJSON] AuthConsentDTO - :> "auth" - :> Capture "id" String + :> "users" :> "consents" :> Post '[SafeJSON] (Headers '[Header "x-trace-uuid" String] UserTokenDTO) -detail_consents_POST +list_consents_POST :: Maybe String -> Maybe String -> AuthConsentDTO - -> String -> BaseContextM (Headers '[Header "x-trace-uuid" String] UserTokenDTO) -detail_consents_POST mServerUrl mUserAgent reqDto authId = +list_consents_POST mServerUrl mUserAgent reqDto = runInUnauthService mServerUrl Transactional $ addTraceUuidHeader =<< confirmConsents reqDto Nothing diff --git a/wizard-server/src/Wizard/Api/Handler/User/List_Current_Email_PUT.hs b/wizard-server/src/Wizard/Api/Handler/User/List_Current_Email_PUT.hs new file mode 100644 index 000000000..5390f1783 --- /dev/null +++ b/wizard-server/src/Wizard/Api/Handler/User/List_Current_Email_PUT.hs @@ -0,0 +1,30 @@ +module Wizard.Api.Handler.User.List_Current_Email_PUT where + +import Servant + +import Shared.Common.Api.Handler.Common +import Shared.Common.Model.Context.TransactionState +import Wizard.Api.Handler.Common +import Wizard.Model.Context.BaseContext +import Wizard.Service.User.UserService + +type List_Current_Email_PUT = + Header "Authorization" String + :> Header "Host" String + :> "users" + :> "current" + :> "email" + :> QueryParam' '[Required] "hash" String + :> Put '[SafeJSON] (Headers '[Header "x-trace-uuid" String] NoContent) + +list_current_email_PUT + :: Maybe String + -> Maybe String + -> String + -> BaseContextM (Headers '[Header "x-trace-uuid" String] NoContent) +list_current_email_PUT mTokenHeader mServerUrl hash = + getMaybeAuthServiceExecutor mTokenHeader mServerUrl $ \runInAuthService -> + runInAuthService Transactional $ + addTraceUuidHeader =<< do + confirmEmailChange hash + return NoContent diff --git a/wizard-server/src/Wizard/Api/Handler/User/List_Current_Identities_GET.hs b/wizard-server/src/Wizard/Api/Handler/User/List_Current_Identities_GET.hs new file mode 100644 index 000000000..01b1549f7 --- /dev/null +++ b/wizard-server/src/Wizard/Api/Handler/User/List_Current_Identities_GET.hs @@ -0,0 +1,28 @@ +module Wizard.Api.Handler.User.List_Current_Identities_GET where + +import Servant + +import Shared.Common.Api.Handler.Common +import Shared.Common.Model.Context.TransactionState +import Wizard.Api.Handler.Common +import Wizard.Model.Context.BaseContext +import Wizard.Service.User.ExternalIdentity.UserExternalIdentityService +import WizardLib.Public.Api.Resource.User.UserOpenIdIdentityDTO +import WizardLib.Public.Api.Resource.User.UserOpenIdIdentityJM () + +type List_Current_Identities_GET = + Header "Authorization" String + :> Header "Host" String + :> "users" + :> "current" + :> "identities" + :> Get '[SafeJSON] (Headers '[Header "x-trace-uuid" String] [UserOpenIdIdentityDTO]) + +list_current_identities_GET + :: Maybe String + -> Maybe String + -> BaseContextM (Headers '[Header "x-trace-uuid" String] [UserOpenIdIdentityDTO]) +list_current_identities_GET mTokenHeader mServerUrl = + getAuthServiceExecutor mTokenHeader mServerUrl $ \runInAuthService -> + runInAuthService NoTransaction $ + addTraceUuidHeader =<< getUserIdentities diff --git a/wizard-server/src/Wizard/Api/Handler/User/List_From_External_POST.hs b/wizard-server/src/Wizard/Api/Handler/User/List_From_External_POST.hs new file mode 100644 index 000000000..08d02d6d2 --- /dev/null +++ b/wizard-server/src/Wizard/Api/Handler/User/List_From_External_POST.hs @@ -0,0 +1,31 @@ +module Wizard.Api.Handler.User.List_From_External_POST where + +import Servant + +import Shared.Common.Api.Handler.Common +import Shared.Common.Model.Context.TransactionState +import Wizard.Api.Handler.Common +import Wizard.Model.Context.BaseContext +import Wizard.Service.User.RegistrationPending.UserRegistrationPendingService +import WizardLib.Public.Api.Resource.User.UserFromExternalDTO +import WizardLib.Public.Api.Resource.User.UserFromExternalJM () +import WizardLib.Public.Api.Resource.UserToken.UserTokenDTO + +type List_From_External_POST = + Header "Host" String + :> Header "Accept-Language" String + :> Header "User-Agent" String + :> ReqBody '[SafeJSON] UserFromExternalDTO + :> "users" + :> "from-external" + :> Post '[SafeJSON] (Headers '[Header "x-trace-uuid" String] UserTokenDTO) + +list_from_external_POST + :: Maybe String + -> Maybe String + -> Maybe String + -> UserFromExternalDTO + -> BaseContextM (Headers '[Header "x-trace-uuid" String] UserTokenDTO) +list_from_external_POST mServerUrl mAcceptLanguages mUserAgent reqDto = + runInUnauthService mServerUrl Transactional $ + addTraceUuidHeader =<< completeExternalRegistration reqDto mAcceptLanguages mUserAgent diff --git a/wizard-server/src/Wizard/Api/Handler/UserEmailLink/Api.hs b/wizard-server/src/Wizard/Api/Handler/UserEmailLink/Api.hs new file mode 100644 index 000000000..c344507ef --- /dev/null +++ b/wizard-server/src/Wizard/Api/Handler/UserEmailLink/Api.hs @@ -0,0 +1,17 @@ +module Wizard.Api.Handler.UserEmailLink.Api where + +import Servant +import Servant.Swagger.Tags + +import Wizard.Api.Handler.UserEmailLink.List_POST +import Wizard.Model.Context.BaseContext + +type UserEmailLinkAPI = + Tags "User Email Link" + :> List_POST + +userEmailLinkApi :: Proxy UserEmailLinkAPI +userEmailLinkApi = Proxy + +userEmailLinkServer :: ServerT UserEmailLinkAPI BaseContextM +userEmailLinkServer = list_POST diff --git a/wizard-server/src/Wizard/Api/Handler/ActionKey/List_POST.hs b/wizard-server/src/Wizard/Api/Handler/UserEmailLink/List_POST.hs similarity index 52% rename from wizard-server/src/Wizard/Api/Handler/ActionKey/List_POST.hs rename to wizard-server/src/Wizard/Api/Handler/UserEmailLink/List_POST.hs index e0de9ffd1..f5ad54603 100644 --- a/wizard-server/src/Wizard/Api/Handler/ActionKey/List_POST.hs +++ b/wizard-server/src/Wizard/Api/Handler/UserEmailLink/List_POST.hs @@ -1,23 +1,23 @@ -module Wizard.Api.Handler.ActionKey.List_POST where +module Wizard.Api.Handler.UserEmailLink.List_POST where import Servant -import Shared.ActionKey.Api.Resource.ActionKey.ActionKeyDTO import Shared.Common.Api.Handler.Common import Shared.Common.Model.Context.TransactionState +import Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkDTO import Wizard.Api.Handler.Common -import Wizard.Api.Resource.ActionKey.ActionKeyTypeJM () -import Wizard.Model.ActionKey.ActionKeyType +import Wizard.Api.Resource.UserEmailLink.UserEmailLinkTypeJM () import Wizard.Model.Context.BaseContext +import Wizard.Model.UserEmailLink.UserEmailLinkType import Wizard.Service.User.UserService type List_POST = Header "Host" String - :> ReqBody '[SafeJSON] (ActionKeyDTO ActionKeyType) - :> "action-keys" + :> ReqBody '[SafeJSON] (UserEmailLinkDTO UserEmailLinkType) + :> "user-email-links" :> Verb 'POST 201 '[SafeJSON] (Headers '[Header "x-trace-uuid" String] NoContent) -list_POST :: Maybe String -> ActionKeyDTO ActionKeyType -> BaseContextM (Headers '[Header "x-trace-uuid" String] NoContent) +list_POST :: Maybe String -> UserEmailLinkDTO UserEmailLinkType -> BaseContextM (Headers '[Header "x-trace-uuid" String] NoContent) list_POST mServerUrl reqDto = runInUnauthService mServerUrl Transactional $ addTraceUuidHeader =<< do diff --git a/wizard-server/src/Wizard/Api/Resource/ActionKey/ActionKeyTypeJM.hs b/wizard-server/src/Wizard/Api/Resource/ActionKey/ActionKeyTypeJM.hs deleted file mode 100644 index eefbdf566..000000000 --- a/wizard-server/src/Wizard/Api/Resource/ActionKey/ActionKeyTypeJM.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Wizard.Api.Resource.ActionKey.ActionKeyTypeJM where - -import Data.Aeson - -import Wizard.Model.ActionKey.ActionKeyType - -instance FromJSON ActionKeyType - -instance ToJSON ActionKeyType diff --git a/wizard-server/src/Wizard/Api/Resource/ActionKey/ActionKeyTypeSM.hs b/wizard-server/src/Wizard/Api/Resource/ActionKey/ActionKeyTypeSM.hs deleted file mode 100644 index 1a6a9f891..000000000 --- a/wizard-server/src/Wizard/Api/Resource/ActionKey/ActionKeyTypeSM.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Wizard.Api.Resource.ActionKey.ActionKeyTypeSM where - -import Data.Swagger - -import Shared.ActionKey.Api.Resource.ActionKey.ActionKeyDTO -import Shared.ActionKey.Api.Resource.ActionKey.ActionKeyJM () -import Shared.Common.Util.Swagger -import Wizard.Api.Resource.ActionKey.ActionKeyTypeJM () -import Wizard.Database.Migration.Development.ActionKey.Data.ActionKeys -import Wizard.Model.ActionKey.ActionKeyType - -instance ToSchema ActionKeyType - -instance ToSchema (ActionKeyDTO ActionKeyType) where - declareNamedSchema = toSwagger forgottenPasswordActionKeyDto diff --git a/wizard-server/src/Wizard/Api/Resource/Config/ClientConfigDTO.hs b/wizard-server/src/Wizard/Api/Resource/Config/ClientConfigDTO.hs index 0b97a31f5..d4e8166ed 100644 --- a/wizard-server/src/Wizard/Api/Resource/Config/ClientConfigDTO.hs +++ b/wizard-server/src/Wizard/Api/Resource/Config/ClientConfigDTO.hs @@ -51,7 +51,7 @@ data ClientConfigAuthExternalDTO = ClientConfigAuthExternalDTO deriving (Generic, Eq, Show) data ClientConfigAuthExternalServiceDTO = ClientConfigAuthExternalServiceDTO - { aId :: String + { uuid :: U.UUID , name :: String , url :: String , style :: OpenIdClientStyle diff --git a/wizard-server/src/Wizard/Api/Resource/Config/ClientConfigJM.hs b/wizard-server/src/Wizard/Api/Resource/Config/ClientConfigJM.hs index 21e5d0d7d..969eecffd 100644 --- a/wizard-server/src/Wizard/Api/Resource/Config/ClientConfigJM.hs +++ b/wizard-server/src/Wizard/Api/Resource/Config/ClientConfigJM.hs @@ -4,6 +4,7 @@ import Data.Aeson import Shared.Common.Api.Resource.Config.SimpleFeatureJM () import Shared.Common.Util.Aeson +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientStyleJM () import Wizard.Api.Resource.Config.ClientConfigDTO import Wizard.Api.Resource.Plugin.PluginListJM () import Wizard.Api.Resource.Tenant.Config.TenantConfigJM () diff --git a/wizard-server/src/Wizard/Api/Resource/Config/ClientConfigSM.hs b/wizard-server/src/Wizard/Api/Resource/Config/ClientConfigSM.hs index 0acf46b0c..c59b6a56a 100644 --- a/wizard-server/src/Wizard/Api/Resource/Config/ClientConfigSM.hs +++ b/wizard-server/src/Wizard/Api/Resource/Config/ClientConfigSM.hs @@ -6,6 +6,7 @@ import Data.Swagger import Shared.Common.Api.Resource.Common.AesonSM () import qualified Shared.Common.Model.Config.ServerConfigDM as S_S import Shared.Common.Util.Swagger +import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientStyleSM () import Wizard.Api.Resource.Config.ClientConfigDTO import Wizard.Api.Resource.Config.ClientConfigJM () import Wizard.Api.Resource.Plugin.PluginListSM () @@ -19,19 +20,20 @@ import Wizard.Model.Config.ServerConfig import qualified Wizard.Model.Config.ServerConfigDM as S import Wizard.Service.Config.Client.ClientConfigMapper import Wizard.Service.User.UserMapper +import WizardLib.Public.Database.Migration.Development.OpenId.Data.OpenIdClients import qualified WizardLib.Public.Database.Migration.Development.Tenant.Data.TenantConfigs as STC instance ToSchema ClientConfigDTO where - declareNamedSchema = toSwaggerWithType "type" (toClientConfigDTO S.defaultConfig TC.defaultOrganization TC.defaultAuthentication TC.defaultPrivacyAndSupport TC.defaultDashboardAndLoginScreen STC.defaultLookAndFeel TC.defaultRegistry TC.defaultProject TC.defaultSubmission STC.defaultFeatures TC.defaultOwl (Just $ toUserProfile (toDTO userAlbert) [] M.empty) [] [plugin1List] M.empty defaultTenant) + declareNamedSchema = toSwaggerWithType "type" (toClientConfigDTO S.defaultConfig TC.defaultOrganization TC.defaultAuthentication [defaultOpenIdClient] TC.defaultPrivacyAndSupport TC.defaultDashboardAndLoginScreen STC.defaultLookAndFeel TC.defaultRegistry TC.defaultProject TC.defaultSubmission STC.defaultFeatures TC.defaultOwl (Just $ toUserProfile (toDTO userAlbert) [] M.empty) [] [plugin1List] M.empty defaultTenant) instance ToSchema ClientConfigAuthDTO where - declareNamedSchema = toSwagger (toClientAuthDTO TC.defaultAuthentication) + declareNamedSchema = toSwagger (toClientAuthDTO TC.defaultAuthentication [defaultOpenIdClient]) instance ToSchema ClientConfigAuthExternalDTO where - declareNamedSchema = toSwagger (toClientAuthExternalDTO TC.defaultAuthenticationExternal) + declareNamedSchema = toSwagger (toClientAuthExternalDTO [defaultOpenIdClient]) instance ToSchema ClientConfigAuthExternalServiceDTO where - declareNamedSchema = toSwagger (toClientAuthExternalServiceDTO TC.defaultAuthenticationExternalService) + declareNamedSchema = toSwagger (toClientAuthExternalServiceDTO defaultOpenIdClient) instance ToSchema ClientConfigRegistryDTO where declareNamedSchema = toSwagger (toClientConfigRegistryDTO S.defaultRegistry TC.defaultRegistry) diff --git a/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigChangeDTO.hs b/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigChangeDTO.hs index 4917758cc..4a8359e2f 100644 --- a/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigChangeDTO.hs +++ b/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigChangeDTO.hs @@ -5,8 +5,6 @@ import qualified Data.UUID as U import GHC.Generics import Shared.Common.Model.Config.SimpleFeature -import Shared.OpenId.Model.OpenId.OpenIdClientParameter -import Shared.OpenId.Model.OpenId.OpenIdClientStyle import Wizard.Model.Tenant.Config.TenantConfig import WizardLib.Public.Api.Resource.Tenant.Config.TenantConfigChangeDTO @@ -34,23 +32,6 @@ data TenantConfigOrganizationChangeDTO = TenantConfigOrganizationChangeDTO data TenantConfigAuthenticationChangeDTO = TenantConfigAuthenticationChangeDTO { defaultRole :: String , internal :: TenantConfigAuthenticationInternal - , external :: TenantConfigAuthenticationExternalChangeDTO - } - deriving (Generic, Eq, Show) - -data TenantConfigAuthenticationExternalChangeDTO = TenantConfigAuthenticationExternalChangeDTO - { services :: [TenantConfigAuthenticationExternalServiceChangeDTO] - } - deriving (Generic, Eq, Show) - -data TenantConfigAuthenticationExternalServiceChangeDTO = TenantConfigAuthenticationExternalServiceChangeDTO - { aId :: String - , name :: String - , url :: String - , clientId :: String - , clientSecret :: String - , parameters :: [OpenIdClientParameter] - , style :: OpenIdClientStyle } deriving (Generic, Eq, Show) diff --git a/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigChangeJM.hs b/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigChangeJM.hs index 5410e4bde..486866866 100644 --- a/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigChangeJM.hs +++ b/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigChangeJM.hs @@ -26,18 +26,6 @@ instance FromJSON TenantConfigAuthenticationChangeDTO where instance ToJSON TenantConfigAuthenticationChangeDTO where toJSON = genericToJSON jsonOptions -instance FromJSON TenantConfigAuthenticationExternalChangeDTO where - parseJSON = genericParseJSON jsonOptions - -instance ToJSON TenantConfigAuthenticationExternalChangeDTO where - toJSON = genericToJSON jsonOptions - -instance FromJSON TenantConfigAuthenticationExternalServiceChangeDTO where - parseJSON = genericParseJSON jsonOptions - -instance ToJSON TenantConfigAuthenticationExternalServiceChangeDTO where - toJSON = genericToJSON jsonOptions - instance FromJSON TenantConfigPrivacyAndSupportChangeDTO where parseJSON = genericParseJSON jsonOptions diff --git a/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigChangeSM.hs b/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigChangeSM.hs index 9b96e3c9c..fa11b52f7 100644 --- a/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigChangeSM.hs +++ b/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigChangeSM.hs @@ -19,12 +19,6 @@ instance ToSchema TenantConfigOrganizationChangeDTO where instance ToSchema TenantConfigAuthenticationChangeDTO where declareNamedSchema = toSwagger defaultAuthenticationChangeDto -instance ToSchema TenantConfigAuthenticationExternalChangeDTO where - declareNamedSchema = toSwagger defaultAuthenticationExternalChangeDto - -instance ToSchema TenantConfigAuthenticationExternalServiceChangeDTO where - declareNamedSchema = toSwagger defaultAuthenticationExternalServiceChangeDto - instance ToSchema TenantConfigPrivacyAndSupportChangeDTO where declareNamedSchema = toSwagger defaultPrivacyAndSupportChangeDto diff --git a/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigJM.hs b/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigJM.hs index eb172ab0a..3dd8e81d7 100644 --- a/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigJM.hs +++ b/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigJM.hs @@ -5,8 +5,6 @@ import Data.Aeson import Shared.Common.Api.Resource.Config.SimpleFeatureJM () import Shared.Common.Util.Aeson import Shared.KnowledgeModel.Api.Resource.KnowledgeModel.Package.KnowledgeModelPackagePatternJM () -import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientParameterJM () -import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientStyleJM () import Wizard.Api.Resource.Project.ProjectSharingJM () import Wizard.Api.Resource.Project.ProjectVisibilityJM () import Wizard.Model.Tenant.Config.TenantConfig @@ -42,18 +40,6 @@ instance FromJSON TenantConfigAuthenticationInternalTwoFactorAuth where instance ToJSON TenantConfigAuthenticationInternalTwoFactorAuth where toJSON = genericToJSON jsonOptions -instance FromJSON TenantConfigAuthenticationExternal where - parseJSON = genericParseJSON jsonOptions - -instance ToJSON TenantConfigAuthenticationExternal where - toJSON = genericToJSON jsonOptions - -instance FromJSON TenantConfigAuthenticationExternalService where - parseJSON = genericParseJSON jsonOptions - -instance ToJSON TenantConfigAuthenticationExternalService where - toJSON = genericToJSON jsonOptions - instance FromJSON TenantConfigPrivacyAndSupport where parseJSON = genericParseJSON jsonOptions diff --git a/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigSM.hs b/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigSM.hs index 4c1833788..6a6e53179 100644 --- a/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigSM.hs +++ b/wizard-server/src/Wizard/Api/Resource/Tenant/Config/TenantConfigSM.hs @@ -5,8 +5,6 @@ import Data.Swagger import Shared.Common.Api.Resource.Config.SimpleFeatureSM () import Shared.Common.Util.Swagger import Shared.KnowledgeModel.Api.Resource.KnowledgeModel.Package.KnowledgeModelPackagePatternSM () -import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientParameterSM () -import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientStyleSM () import Wizard.Api.Resource.Project.ProjectSharingSM () import Wizard.Api.Resource.Project.ProjectVisibilitySM () import Wizard.Api.Resource.Tenant.Config.TenantConfigJM () @@ -29,12 +27,6 @@ instance ToSchema TenantConfigAuthenticationInternal where instance ToSchema TenantConfigAuthenticationInternalTwoFactorAuth where declareNamedSchema = toSwagger defaultAuthenticationInternalTwoFactorAuth -instance ToSchema TenantConfigAuthenticationExternal where - declareNamedSchema = toSwagger defaultAuthenticationExternal - -instance ToSchema TenantConfigAuthenticationExternalService where - declareNamedSchema = toSwagger defaultAuthenticationExternalService - instance ToSchema TenantConfigPrivacyAndSupport where declareNamedSchema = toSwagger defaultPrivacyAndSupport diff --git a/wizard-server/src/Wizard/Api/Resource/User/UserDTO.hs b/wizard-server/src/Wizard/Api/Resource/User/UserDTO.hs index 4259f0b35..0fdd2e9d2 100644 --- a/wizard-server/src/Wizard/Api/Resource/User/UserDTO.hs +++ b/wizard-server/src/Wizard/Api/Resource/User/UserDTO.hs @@ -14,7 +14,6 @@ data UserDTO = UserDTO , lastName :: String , email :: String , affiliation :: Maybe String - , sources :: [String] , uRole :: String , permissions :: [String] , active :: Bool @@ -23,6 +22,8 @@ data UserDTO = UserDTO , lastSeenNewsId :: Maybe String , createdAt :: UTCTime , updatedAt :: UTCTime + , emailVerifiedAt :: Maybe UTCTime + , emailPending :: Maybe String } deriving (Show, Generic) @@ -33,12 +34,13 @@ instance Eq UserDTO where && a.lastName == b.lastName && a.email == b.email && a.affiliation == b.affiliation - && a.sources == b.sources && a.uRole == b.uRole && a.permissions == b.permissions && a.active == b.active && a.imageUrl == b.imageUrl && a.locale == b.locale && a.lastSeenNewsId == b.lastSeenNewsId + && a.emailVerifiedAt == b.emailVerifiedAt + && a.emailPending == b.emailPending instance Hashable UserDTO diff --git a/wizard-server/src/Wizard/Api/Resource/UserEmailLink/UserEmailLinkTypeJM.hs b/wizard-server/src/Wizard/Api/Resource/UserEmailLink/UserEmailLinkTypeJM.hs new file mode 100644 index 000000000..e114118b4 --- /dev/null +++ b/wizard-server/src/Wizard/Api/Resource/UserEmailLink/UserEmailLinkTypeJM.hs @@ -0,0 +1,9 @@ +module Wizard.Api.Resource.UserEmailLink.UserEmailLinkTypeJM where + +import Data.Aeson + +import Wizard.Model.UserEmailLink.UserEmailLinkType + +instance FromJSON UserEmailLinkType + +instance ToJSON UserEmailLinkType diff --git a/wizard-server/src/Wizard/Api/Resource/UserEmailLink/UserEmailLinkTypeSM.hs b/wizard-server/src/Wizard/Api/Resource/UserEmailLink/UserEmailLinkTypeSM.hs new file mode 100644 index 000000000..87ae8b852 --- /dev/null +++ b/wizard-server/src/Wizard/Api/Resource/UserEmailLink/UserEmailLinkTypeSM.hs @@ -0,0 +1,15 @@ +module Wizard.Api.Resource.UserEmailLink.UserEmailLinkTypeSM where + +import Data.Swagger + +import Shared.Common.Util.Swagger +import Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkDTO +import Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkJM () +import Wizard.Api.Resource.UserEmailLink.UserEmailLinkTypeJM () +import Wizard.Database.Migration.Development.UserEmailLink.Data.UserEmailLinks +import Wizard.Model.UserEmailLink.UserEmailLinkType + +instance ToSchema UserEmailLinkType + +instance ToSchema (UserEmailLinkDTO UserEmailLinkType) where + declareNamedSchema = toSwagger forgottenPasswordUserEmailLinkDto diff --git a/wizard-server/src/Wizard/Application.hs b/wizard-server/src/Wizard/Application.hs index 6f71be3ac..e7ba41f6f 100755 --- a/wizard-server/src/Wizard/Application.hs +++ b/wizard-server/src/Wizard/Application.hs @@ -8,8 +8,10 @@ import Data.Pool (Pool) import Database.PostgreSQL.Simple (Connection) import Network.HTTP.Client (Manager) import Network.Minio (MinioConn) +import System.Environment (lookupEnv, setEnv) import Shared.Common.Application +import Shared.Common.Bootstrap.AwsAppConfig import Shared.Common.Bootstrap.Web import Shared.Common.Model.Config.BuildInfoConfig import Shared.Common.Model.Config.ServerConfig @@ -32,7 +34,7 @@ import Wizard.Worker.PermanentWorkers import WizardLib.Public.Util.Jinja (verifyJinja) runApplication :: IO () -runApplication = do +runApplication = runWebServerWithWorkers [putStrLn asciiLogo, verifyJinja] serverConfigFile @@ -52,7 +54,15 @@ createBaseContext serverConfig buildInfoConfig dbPool s3Client httpClientManager return BaseContext {..} afterDbMigrationHook :: BaseContext -> IO () -afterDbMigrationHook _ = return () +afterDbMigrationHook context = do + mAwsAppConfig <- lookupEnv "AWS_APP_CONFIG" + case mAwsAppConfig of + Just _ -> do + (path, poller) <- resolveConfigPath context.serverConfig.general.integrationConfig + setEnv "INTEGRATION_CONFIG_PATH" path + _ <- forkIO $ poller context.shutdownFlag + return () + Nothing -> return () runWebServer :: BaseContext -> IO () runWebServer context = runWebServerFactory context getSentryIdentity loggingMiddleware webApi webServer diff --git a/wizard-server/src/Wizard/Database/DAO/Project/ProjectCommentThreadDAO.hs b/wizard-server/src/Wizard/Database/DAO/Project/ProjectCommentThreadDAO.hs index b6e944d75..2cc371fd6 100644 --- a/wizard-server/src/Wizard/Database/DAO/Project/ProjectCommentThreadDAO.hs +++ b/wizard-server/src/Wizard/Database/DAO/Project/ProjectCommentThreadDAO.hs @@ -255,6 +255,8 @@ findProjectCommentThreadsForNotifying = do let sql = "SELECT project.uuid, \ \ project.name, \ + \ project.knowledge_model_package_uuid, \ + \ project.selected_question_tag_uuids, \ \ project.tenant_uuid, \ \ thread.uuid, \ \ thread.path, \ diff --git a/wizard-server/src/Wizard/Database/DAO/Tenant/Config/TenantConfigAuthenticationDAO.hs b/wizard-server/src/Wizard/Database/DAO/Tenant/Config/TenantConfigAuthenticationDAO.hs index 99d9858fb..13a529d7b 100644 --- a/wizard-server/src/Wizard/Database/DAO/Tenant/Config/TenantConfigAuthenticationDAO.hs +++ b/wizard-server/src/Wizard/Database/DAO/Tenant/Config/TenantConfigAuthenticationDAO.hs @@ -8,7 +8,6 @@ import Database.PostgreSQL.Simple.ToField import Database.PostgreSQL.Simple.ToRow import GHC.Int -import Shared.Common.Model.Common.Sort import Wizard.Database.DAO.Common import Wizard.Database.Mapping.Tenant.Config.TenantConfigAuthentication () import Wizard.Model.Context.AppContext @@ -21,33 +20,21 @@ findTenantConfigAuthentication = do findTenantConfigAuthenticationByUuid tenantUuid findTenantConfigAuthenticationByUuid :: U.UUID -> AppContextM TenantConfigAuthentication -findTenantConfigAuthenticationByUuid tenantUuid = do - config <- createFindEntityByFn "config_authentication" [("tenant_uuid", U.toString tenantUuid)] - externalServices <- createFindEntitiesBySortedFn "config_authentication_openid" [("tenant_uuid", U.toString tenantUuid)] [Sort "id" Ascending] - return $ config {external = config.external {services = externalServices}} +findTenantConfigAuthenticationByUuid tenantUuid = + createFindEntityByFn "config_authentication" [("tenant_uuid", U.toString tenantUuid)] insertTenantConfigAuthentication :: TenantConfigAuthentication -> AppContextM Int64 insertTenantConfigAuthentication = createInsertFn "config_authentication" -insertTenantConfigAuthenticationExternalService :: TenantConfigAuthenticationExternalService -> AppContextM Int64 -insertTenantConfigAuthenticationExternalService = createInsertFn "config_authentication_openid" - updateTenantConfigAuthentication :: TenantConfigAuthentication -> AppContextM Int64 updateTenantConfigAuthentication config = do let sql = - fromString $ - "UPDATE config_authentication SET tenant_uuid = ?, default_role = ?, internal_registration_enabled = ?, internal_two_factor_auth_enabled = ?, internal_two_factor_auth_code_length = ?, internal_two_factor_auth_code_expiration = ?, created_at = ?, updated_at = ? WHERE tenant_uuid = ?; \ - \DELETE FROM config_authentication_openid WHERE tenant_uuid = ?;" - ++ concatMap (const "INSERT INTO config_authentication_openid VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);") config.external.services - let params = - toRow config - ++ [toField config.tenantUuid, toField config.tenantUuid] - ++ concatMap toRow config.external.services + fromString + "UPDATE config_authentication SET tenant_uuid = ?, default_role = ?, internal_registration_enabled = ?, internal_two_factor_auth_enabled = ?, internal_two_factor_auth_code_length = ?, internal_two_factor_auth_code_expiration = ?, created_at = ?, updated_at = ?, internal_non_admin_login_enabled = ?, internal_session_expiration = ?, internal_user_email_link_expiration = ? WHERE tenant_uuid = ?" + let params = toRow config ++ [toField config.tenantUuid] logQuery sql params let action conn = execute conn sql params runDB action deleteTenantConfigAuthentications :: AppContextM Int64 -deleteTenantConfigAuthentications = do - createDeleteEntitiesFn "config_authentication_openid" - createDeleteEntitiesFn "config_authentication" +deleteTenantConfigAuthentications = createDeleteEntitiesFn "config_authentication" diff --git a/wizard-server/src/Wizard/Database/DAO/User/UserDAO.hs b/wizard-server/src/Wizard/Database/DAO/User/UserDAO.hs index f1aedebed..8c7a6ce29 100644 --- a/wizard-server/src/Wizard/Database/DAO/User/UserDAO.hs +++ b/wizard-server/src/Wizard/Database/DAO/User/UserDAO.hs @@ -156,7 +156,7 @@ insertUser user = do tenantUuid <- asks currentTenantUuid let sql = fromString - "INSERT INTO user_entity VALUES (?, ?, ?, ?, ?, ?, ?::varchar[], ?, ?::varchar[], ?, ?, ?, ?, ?, ?, ?, ?, ?)" + "INSERT INTO user_entity VALUES (?, ?, ?, ?, ?, ?, ?, ?::varchar[], ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" let params = toRow user logQuery sql params let action conn = execute conn sql params @@ -168,7 +168,7 @@ updateUserByUuid :: User -> AppContextM Int64 updateUserByUuid user = do let sql = fromString - "UPDATE user_entity SET uuid = ?, first_name = ?, last_name = ?, email = ?, password_hash = ?, affiliation = ?, sources = ?, role = ?, permissions = ?, active = ?, image_url = ?, last_visited_at = ?, created_at = ?, updated_at = ?, tenant_uuid = ?, machine = ?, locale = ?, last_seen_news_id = ? WHERE tenant_uuid = ? AND uuid = ?" + "UPDATE user_entity SET uuid = ?, first_name = ?, last_name = ?, email = ?, password_hash = ?, affiliation = ?, role = ?, permissions = ?, active = ?, image_url = ?, last_visited_at = ?, created_at = ?, updated_at = ?, tenant_uuid = ?, machine = ?, locale = ?, last_seen_news_id = ?, email_verified_at = ?, email_pending = ? WHERE tenant_uuid = ? AND uuid = ?" let params = toRow user ++ [toField user.tenantUuid, toField user.uuid] logQuery sql params let action conn = execute conn sql params diff --git a/wizard-server/src/Wizard/Database/DAO/UserEmailLink/UserEmailLinkDAO.hs b/wizard-server/src/Wizard/Database/DAO/UserEmailLink/UserEmailLinkDAO.hs new file mode 100644 index 000000000..4758d7887 --- /dev/null +++ b/wizard-server/src/Wizard/Database/DAO/UserEmailLink/UserEmailLinkDAO.hs @@ -0,0 +1,20 @@ +module Wizard.Database.DAO.UserEmailLink.UserEmailLinkDAO where + +import Data.String +import Database.PostgreSQL.Simple +import GHC.Int + +import Wizard.Database.DAO.Common +import Wizard.Model.Context.AppContext + +deleteUserEmailLinksExpiredByTenantConfig :: AppContextM Int64 +deleteUserEmailLinksExpiredByTenantConfig = do + let sql = + fromString + "DELETE FROM user_email_link \ + \USING config_authentication \ + \WHERE user_email_link.tenant_uuid = config_authentication.tenant_uuid \ + \ AND user_email_link.created_at < (now() - (config_authentication.internal_user_email_link_expiration * interval '1 hour'));" + logQuery sql () + let action conn = execute_ conn sql + runDB action diff --git a/wizard-server/src/Wizard/Database/Mapping/ActionKey/ActionKeyType.hs b/wizard-server/src/Wizard/Database/Mapping/ActionKey/ActionKeyType.hs deleted file mode 100644 index 5e6671b94..000000000 --- a/wizard-server/src/Wizard/Database/Mapping/ActionKey/ActionKeyType.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Wizard.Database.Mapping.ActionKey.ActionKeyType where - -import Database.PostgreSQL.Simple.FromField -import Database.PostgreSQL.Simple.ToField - -import Shared.Common.Database.Mapping.Common -import Wizard.Model.ActionKey.ActionKeyType - -instance ToField ActionKeyType where - toField = toFieldGenericEnum - -instance FromField ActionKeyType where - fromField = fromFieldGenericEnum diff --git a/wizard-server/src/Wizard/Database/Mapping/Project/Comment/ProjectCommentThreadNotification.hs b/wizard-server/src/Wizard/Database/Mapping/Project/Comment/ProjectCommentThreadNotification.hs index a19ccf9a3..396238f72 100644 --- a/wizard-server/src/Wizard/Database/Mapping/Project/Comment/ProjectCommentThreadNotification.hs +++ b/wizard-server/src/Wizard/Database/Mapping/Project/Comment/ProjectCommentThreadNotification.hs @@ -3,6 +3,7 @@ module Wizard.Database.Mapping.Project.Comment.ProjectCommentThreadNotification import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.FromRow +import Database.PostgreSQL.Simple.Types import Wizard.Model.Project.Comment.ProjectCommentThreadNotification import WizardLib.Public.Model.User.UserSimple @@ -11,6 +12,8 @@ instance FromRow ProjectCommentThreadNotification where fromRow = do projectUuid <- field projectName <- field + knowledgeModelPackageUuid <- field + selectedQuestionTagUuids <- fromPGArray <$> field tenantUuid <- field commentThreadUuid <- field path <- field @@ -45,6 +48,7 @@ instance FromRow ProjectCommentThreadNotification where } _ -> Nothing text <- field + let questionTitle = Nothing clientUrl <- field appTitle <- field logoUrl <- field diff --git a/wizard-server/src/Wizard/Database/Mapping/Submission/SubmissionList.hs b/wizard-server/src/Wizard/Database/Mapping/Submission/SubmissionList.hs index ee5fb5504..cca3a42fa 100644 --- a/wizard-server/src/Wizard/Database/Mapping/Submission/SubmissionList.hs +++ b/wizard-server/src/Wizard/Database/Mapping/Submission/SubmissionList.hs @@ -5,7 +5,7 @@ import Database.PostgreSQL.Simple.FromRow import Wizard.Database.Mapping.Submission.Submission () import Wizard.Model.Submission.SubmissionList -import WizardLib.Public.Model.User.UserSuggestion +import WizardLib.Public.Database.Mapping.User.UserSuggestion instance FromRow SubmissionList where fromRow = do @@ -18,17 +18,5 @@ instance FromRow SubmissionList where updatedAt <- field serviceId <- field serviceName <- field - createdByUuid <- field - createdByFirstName <- field - createdByLastName <- field - createdByGravatarHash <- field - createdByImageUrl <- field - let createdBy = - UserSuggestion - { uuid = createdByUuid - , firstName = createdByFirstName - , lastName = createdByLastName - , gravatarHash = createdByGravatarHash - , imageUrl = createdByImageUrl - } + createdBy <- fieldUserSuggestion' return $ SubmissionList {..} diff --git a/wizard-server/src/Wizard/Database/Mapping/Tenant/Config/TenantConfigAuthentication.hs b/wizard-server/src/Wizard/Database/Mapping/Tenant/Config/TenantConfigAuthentication.hs index f6c490d09..d159b2ad6 100644 --- a/wizard-server/src/Wizard/Database/Mapping/Tenant/Config/TenantConfigAuthentication.hs +++ b/wizard-server/src/Wizard/Database/Mapping/Tenant/Config/TenantConfigAuthentication.hs @@ -1,14 +1,11 @@ module Wizard.Database.Mapping.Tenant.Config.TenantConfigAuthentication where import Database.PostgreSQL.Simple -import Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.FromRow import Database.PostgreSQL.Simple.ToField import Database.PostgreSQL.Simple.ToRow import Shared.Common.Model.Config.SimpleFeature -import Shared.OpenId.Api.Resource.OpenId.Client.Definition.OpenIdClientParameterJM () -import Shared.OpenId.Model.OpenId.OpenIdClientStyle import Wizard.Model.Tenant.Config.TenantConfig instance ToRow TenantConfigAuthentication where @@ -21,6 +18,9 @@ instance ToRow TenantConfigAuthentication where , toField internal.twoFactorAuth.expiration , toField createdAt , toField updatedAt + , toField internal.nonAdminLoginEnabled + , toField internal.sessionExpiration + , toField internal.userEmailLinkExpiration ] instance FromRow TenantConfigAuthentication where @@ -31,41 +31,10 @@ instance FromRow TenantConfigAuthentication where internalTwoFactorAuthEnabled <- field internalTwoFactorAuthCodeLength <- field internalTwoFactorAuthExpiration <- field - let internal = TenantConfigAuthenticationInternal {registration = SimpleFeature {enabled = internalRegistrationEnabled}, twoFactorAuth = TenantConfigAuthenticationInternalTwoFactorAuth {enabled = internalTwoFactorAuthEnabled, codeLength = internalTwoFactorAuthCodeLength, expiration = internalTwoFactorAuthExpiration}} - let external = TenantConfigAuthenticationExternal {services = []} createdAt <- field updatedAt <- field + internalNonAdminLoginEnabled <- field + internalSessionExpiration <- field + internalUserEmailLinkExpiration <- field + let internal = TenantConfigAuthenticationInternal {registration = SimpleFeature {enabled = internalRegistrationEnabled}, nonAdminLoginEnabled = internalNonAdminLoginEnabled, sessionExpiration = internalSessionExpiration, userEmailLinkExpiration = internalUserEmailLinkExpiration, twoFactorAuth = TenantConfigAuthenticationInternalTwoFactorAuth {enabled = internalTwoFactorAuthEnabled, codeLength = internalTwoFactorAuthCodeLength, expiration = internalTwoFactorAuthExpiration}} return $ TenantConfigAuthentication {..} - -instance FromRow TenantConfigAuthenticationExternalService where - fromRow = do - aId <- field - name <- field - url <- field - clientId <- field - clientSecret <- field - parameters <- fieldWith fromJSONField - styleIcon <- field - styleBackground <- field - styleColor <- field - let style = OpenIdClientStyle {icon = styleIcon, background = styleBackground, color = styleColor} - tenantUuid <- field - createdAt <- field - updatedAt <- field - return $ TenantConfigAuthenticationExternalService {..} - -instance ToRow TenantConfigAuthenticationExternalService where - toRow TenantConfigAuthenticationExternalService {..} = - [ toField aId - , toField name - , toField url - , toField clientId - , toField clientSecret - , toJSONField parameters - , toField style.icon - , toField style.background - , toField style.color - , toField tenantUuid - , toField createdAt - , toField updatedAt - ] diff --git a/wizard-server/src/Wizard/Database/Mapping/User/User.hs b/wizard-server/src/Wizard/Database/Mapping/User/User.hs index e24788a17..af09618dd 100644 --- a/wizard-server/src/Wizard/Database/Mapping/User/User.hs +++ b/wizard-server/src/Wizard/Database/Mapping/User/User.hs @@ -17,7 +17,6 @@ instance ToRow User where , toField email , toField passwordHash , toField affiliation - , toField . PGArray $ sources , toField uRole , toField . PGArray $ permissions , toField active @@ -29,6 +28,8 @@ instance ToRow User where , toField machine , toField locale , toField lastSeenNewsId + , toField emailVerifiedAt + , toField emailPending ] instance FromRow User where @@ -39,7 +40,6 @@ instance FromRow User where email <- field passwordHash <- field affiliation <- field - sources <- fromPGArray <$> field uRole <- field permissions <- fromPGArray <$> field active <- field @@ -51,4 +51,6 @@ instance FromRow User where machine <- field locale <- field lastSeenNewsId <- field + emailVerifiedAt <- field + emailPending <- field return $ User {..} diff --git a/wizard-server/src/Wizard/Database/Mapping/User/UserRegistrationPendingServiceType.hs b/wizard-server/src/Wizard/Database/Mapping/User/UserRegistrationPendingServiceType.hs new file mode 100644 index 000000000..483457168 --- /dev/null +++ b/wizard-server/src/Wizard/Database/Mapping/User/UserRegistrationPendingServiceType.hs @@ -0,0 +1,13 @@ +module Wizard.Database.Mapping.User.UserRegistrationPendingServiceType where + +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.ToField + +import Shared.Common.Database.Mapping.Common +import Wizard.Model.User.UserRegistrationPendingServiceType + +instance ToField UserRegistrationPendingServiceType where + toField = toFieldGenericEnum + +instance FromField UserRegistrationPendingServiceType where + fromField = fromFieldGenericEnum diff --git a/wizard-server/src/Wizard/Database/Mapping/UserEmailLink/UserEmailLinkType.hs b/wizard-server/src/Wizard/Database/Mapping/UserEmailLink/UserEmailLinkType.hs new file mode 100644 index 000000000..1ef386e6e --- /dev/null +++ b/wizard-server/src/Wizard/Database/Mapping/UserEmailLink/UserEmailLinkType.hs @@ -0,0 +1,13 @@ +module Wizard.Database.Mapping.UserEmailLink.UserEmailLinkType where + +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.ToField + +import Shared.Common.Database.Mapping.Common +import Wizard.Model.UserEmailLink.UserEmailLinkType + +instance ToField UserEmailLinkType where + toField = toFieldGenericEnum + +instance FromField UserEmailLinkType where + fromField = fromFieldGenericEnum diff --git a/wizard-server/src/Wizard/Database/Migration/Development/ActionKey/ActionKeyMigration.hs b/wizard-server/src/Wizard/Database/Migration/Development/ActionKey/ActionKeyMigration.hs deleted file mode 100644 index b745c829a..000000000 --- a/wizard-server/src/Wizard/Database/Migration/Development/ActionKey/ActionKeyMigration.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Wizard.Database.Migration.Development.ActionKey.ActionKeyMigration where - -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO -import Shared.Common.Constant.Component -import Shared.Common.Util.Logger -import Wizard.Database.Mapping.ActionKey.ActionKeyType () -import Wizard.Database.Migration.Development.ActionKey.Data.ActionKeys -import Wizard.Model.Context.AppContext -import Wizard.Model.Context.ContextLenses () - -runMigration :: AppContextM () -runMigration = do - logInfo _CMP_MIGRATION "(ActionKey/ActionKey) started" - deleteActionKeys - insertActionKey differentActionKey - logInfo _CMP_MIGRATION "(ActionKey/ActionKey) ended" diff --git a/wizard-server/src/Wizard/Database/Migration/Development/Migration.hs b/wizard-server/src/Wizard/Database/Migration/Development/Migration.hs index d12430d15..180ca4e9f 100644 --- a/wizard-server/src/Wizard/Database/Migration/Development/Migration.hs +++ b/wizard-server/src/Wizard/Database/Migration/Development/Migration.hs @@ -11,8 +11,6 @@ import qualified Shared.Component.Database.Migration.Development.Component.Compo import qualified Shared.PersistentCommand.Database.Migration.Development.PersistentCommand.PersistentCommandMigration as PersistentCommand import qualified Shared.Prefab.Database.Migration.Development.Prefab.PrefabMigration as Prefab import qualified Shared.Prefab.Database.Migration.Development.Prefab.PrefabSchemaMigration as Prefab -import qualified Wizard.Database.Migration.Development.ActionKey.ActionKeyMigration as ActionKey -import qualified Wizard.Database.Migration.Development.ActionKey.ActionKeySchemaMigration as ActionKey import qualified Wizard.Database.Migration.Development.Common.CommonSchemaMigration as Common import qualified Wizard.Database.Migration.Development.Document.DocumentMigration as Document import qualified Wizard.Database.Migration.Development.Document.DocumentSchemaMigration as Document @@ -47,9 +45,15 @@ import qualified Wizard.Database.Migration.Development.Tenant.TenantMigration as import qualified Wizard.Database.Migration.Development.Tenant.TenantSchemaMigration as Tenant import qualified Wizard.Database.Migration.Development.User.UserMigration as User import qualified Wizard.Database.Migration.Development.User.UserSchemaMigration as User +import qualified Wizard.Database.Migration.Development.UserEmailLink.UserEmailLinkMigration as UserEmailLink +import qualified Wizard.Database.Migration.Development.UserEmailLink.UserEmailLinkSchemaMigration as UserEmailLink import Wizard.Model.Context.ContextMappers import qualified WizardLib.Public.Database.Migration.Development.ExternalLink.ExternalLinkMigration as ExternalLink import qualified WizardLib.Public.Database.Migration.Development.ExternalLink.ExternalLinkSchemaMigration as ExternalLink +import qualified WizardLib.Public.Database.Migration.Development.OpenId.OpenIdClientMigration as OpenIdClient +import qualified WizardLib.Public.Database.Migration.Development.OpenId.OpenIdClientSchemaMigration as OpenIdClient +import qualified WizardLib.Public.Database.Migration.Development.User.UserOpenIdIdentitySchemaMigration as UserOpenIdIdentity +import qualified WizardLib.Public.Database.Migration.Development.User.UserRegistrationPendingSchemaMigration as UserRegistrationPending runMigration = runAppContextWithBaseContext $ do logInfo _CMP_MIGRATION "started" @@ -71,7 +75,7 @@ runMigration = runAppContextWithBaseContext $ do Prefab.dropTables PersistentCommand.dropTables Submission.dropTables - ActionKey.dropTables + UserEmailLink.dropTables Feedback.dropTables KnowledgeModelMigration.dropTables KnowledgeModelEditor.dropTables @@ -82,8 +86,11 @@ runMigration = runAppContextWithBaseContext $ do KnowledgeModelSecret.dropTables KnowledgeModelPackage.dropTables TemporaryFile.dropTables + UserRegistrationPending.dropTables + UserOpenIdIdentity.dropTables User.dropTables Tenant.dropConfigTables + OpenIdClient.dropTables DocumentTemplate.dropTables Locale.dropTables Plugin.dropTables @@ -100,11 +107,14 @@ runMigration = runAppContextWithBaseContext $ do Locale.createTables DocumentTemplate.createTables Tenant.createConfigTables + OpenIdClient.createTables User.createTables + UserOpenIdIdentity.createTables + UserRegistrationPending.createTables TemporaryFile.createTables KnowledgeModelPackage.createTables KnowledgeModelSecret.createTables - ActionKey.createTables + UserEmailLink.createTables Feedback.createTables KnowledgeModelEditor.createTables KnowledgeModelCache.createTables @@ -137,12 +147,13 @@ runMigration = runAppContextWithBaseContext $ do Locale.runS3Migration -- 11. Load fixtures Tenant.runMigration + OpenIdClient.runMigration Plugin.runMigration User.runMigration KnowledgeModelPackage.runMigration KnowledgeModelSecret.runMigration DocumentTemplate.runMigration - ActionKey.runMigration + UserEmailLink.runMigration KnowledgeModelEditor.runMigration Project.runMigration Feedback.runMigration diff --git a/wizard-server/src/Wizard/Database/Migration/Development/Submission/Data/Submissions.hs b/wizard-server/src/Wizard/Database/Migration/Development/Submission/Data/Submissions.hs index 937270339..b30447b83 100644 --- a/wizard-server/src/Wizard/Database/Migration/Development/Submission/Data/Submissions.hs +++ b/wizard-server/src/Wizard/Database/Migration/Development/Submission/Data/Submissions.hs @@ -30,13 +30,13 @@ submission1 = , serviceId = defaultSubmissionService.sId , documentUuid = doc1.uuid , tenantUuid = defaultTenant.uuid - , createdBy = userAlbert.uuid + , createdBy = Just userAlbert.uuid , createdAt = UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 , updatedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 } submission1List :: SubmissionList -submission1List = toList submission1 defaultSubmissionService userAlbertSuggestion +submission1List = toList submission1 defaultSubmissionService (Just userAlbertSuggestion) submission2 :: Submission submission2 = @@ -48,13 +48,13 @@ submission2 = , serviceId = defaultSubmissionService.sId , documentUuid = doc1.uuid , tenantUuid = defaultTenant.uuid - , createdBy = userAlbert.uuid + , createdBy = Just userAlbert.uuid , createdAt = UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 , updatedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 } submission2Dto :: SubmissionList -submission2Dto = toList submission1 defaultSubmissionService userAlbertSuggestion +submission2Dto = toList submission2 defaultSubmissionService (Just userAlbertSuggestion) differentSubmission1 :: Submission differentSubmission1 = @@ -66,7 +66,7 @@ differentSubmission1 = , serviceId = defaultSubmissionService.sId , documentUuid = differentDoc.uuid , tenantUuid = differentTenant.uuid - , createdBy = userCharles.uuid + , createdBy = Just userCharles.uuid , createdAt = UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 , updatedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 } diff --git a/wizard-server/src/Wizard/Database/Migration/Development/Tenant/Data/TenantConfigs.hs b/wizard-server/src/Wizard/Database/Migration/Development/Tenant/Data/TenantConfigs.hs index 69a57f07f..69b5c9a91 100644 --- a/wizard-server/src/Wizard/Database/Migration/Development/Tenant/Data/TenantConfigs.hs +++ b/wizard-server/src/Wizard/Database/Migration/Development/Tenant/Data/TenantConfigs.hs @@ -9,7 +9,6 @@ import Shared.Common.Util.Date import Shared.DocumentTemplate.Database.Migration.Development.DocumentTemplate.Data.DocumentTemplateFormats import Shared.DocumentTemplate.Database.Migration.Development.DocumentTemplate.Data.DocumentTemplates import Shared.DocumentTemplate.Model.DocumentTemplate.DocumentTemplate -import Shared.OpenId.Database.Migration.Development.OpenId.Data.OpenIds import Wizard.Api.Resource.Tenant.Config.TenantConfigChangeDTO import Wizard.Database.Migration.Development.Tenant.Data.Tenants import Wizard.Model.Project.Project @@ -67,11 +66,10 @@ defaultAuthenticationChangeDto = TenantConfigAuthenticationChangeDTO { defaultRole = _USER_ROLE_RESEARCHER , internal = defaultAuthenticationInternal - , external = defaultAuthenticationExternalChangeDto } defaultAuthenticationInternal :: TenantConfigAuthenticationInternal -defaultAuthenticationInternal = TenantConfigAuthenticationInternal {registration = SimpleFeature True, twoFactorAuth = defaultAuthenticationInternalTwoFactorAuth} +defaultAuthenticationInternal = TenantConfigAuthenticationInternal {registration = SimpleFeature True, nonAdminLoginEnabled = True, sessionExpiration = 14 * 24, userEmailLinkExpiration = 14 * 24, twoFactorAuth = defaultAuthenticationInternalTwoFactorAuth} defaultAuthenticationInternalTwoFactorAuth :: TenantConfigAuthenticationInternalTwoFactorAuth defaultAuthenticationInternalTwoFactorAuth = @@ -81,30 +79,6 @@ defaultAuthenticationInternalTwoFactorAuth = , expiration = 600 } -defaultAuthenticationExternal :: TenantConfigAuthenticationExternal -defaultAuthenticationExternal = TenantConfigAuthenticationExternal {services = [defaultAuthenticationExternalService]} - -defaultAuthenticationExternalChangeDto :: TenantConfigAuthenticationExternalChangeDTO -defaultAuthenticationExternalChangeDto = TenantConfigAuthenticationExternalChangeDTO {services = [defaultAuthenticationExternalServiceChangeDto]} - -defaultAuthenticationExternalService :: TenantConfigAuthenticationExternalService -defaultAuthenticationExternalService = fromAuthenticationExternalServiceChangeDTO defaultAuthenticationExternalServiceChangeDto defaultTenant.uuid (dt' 2018 1 20) (dt' 2018 1 20) - -defaultAuthExternalServiceEncrypted :: TenantConfigAuthenticationExternalService -defaultAuthExternalServiceEncrypted = process defaultSecret defaultAuthenticationExternalService - -defaultAuthenticationExternalServiceChangeDto :: TenantConfigAuthenticationExternalServiceChangeDTO -defaultAuthenticationExternalServiceChangeDto = - TenantConfigAuthenticationExternalServiceChangeDTO - { aId = "google" - , name = "Google" - , url = "https://accounts.google.com" - , clientId = "32559869123-a98908094.apps.googleusercontent.com" - , clientSecret = "sad89089023" - , parameters = [openIdClientDefinitionParameter] - , style = openIdClientDefinitionStyle - } - defaultPrivacyAndSupport :: TenantConfigPrivacyAndSupport defaultPrivacyAndSupport = fromPrivacyAndSupportChangeDTO defaultPrivacyAndSupportChangeDto defaultTenant.uuid (dt' 2018 1 20) (dt' 2018 1 20) diff --git a/wizard-server/src/Wizard/Database/Migration/Development/Tenant/TenantMigration.hs b/wizard-server/src/Wizard/Database/Migration/Development/Tenant/TenantMigration.hs index a7a789b7c..341be9a88 100644 --- a/wizard-server/src/Wizard/Database/Migration/Development/Tenant/TenantMigration.hs +++ b/wizard-server/src/Wizard/Database/Migration/Development/Tenant/TenantMigration.hs @@ -43,7 +43,6 @@ runConfigMigration = do deleteTenantConfigOrganizations insertTenantConfigOrganization defaultOrganization insertTenantConfigAuthentication defaultAuthenticationEncrypted - insertTenantConfigAuthenticationExternalService defaultAuthExternalServiceEncrypted insertTenantConfigPrivacyAndSupport defaultPrivacyAndSupport insertTenantConfigDashboardAndLoginScreen defaultDashboardAndLoginScreen insertTenantConfigDashboardAndLoginScreenAnnouncement defaultDashboardAndLoginScreenAnnouncement diff --git a/wizard-server/src/Wizard/Database/Migration/Development/Tenant/TenantSchemaMigration.hs b/wizard-server/src/Wizard/Database/Migration/Development/Tenant/TenantSchemaMigration.hs index f114a7d5e..df7747e81 100644 --- a/wizard-server/src/Wizard/Database/Migration/Development/Tenant/TenantSchemaMigration.hs +++ b/wizard-server/src/Wizard/Database/Migration/Development/Tenant/TenantSchemaMigration.hs @@ -36,7 +36,6 @@ dropConfigTables = do \DROP TABLE IF EXISTS config_dashboard_and_login_screen_announcement; \ \DROP TABLE IF EXISTS config_dashboard_and_login_screen; \ \DROP TABLE IF EXISTS config_privacy_and_support; \ - \DROP TABLE IF EXISTS config_authentication_openid; \ \DROP TABLE IF EXISTS config_authentication; \ \DROP TABLE IF EXISTS config_organization; \ \DROP TYPE IF EXISTS config_dashboard_and_login_screen_announcement_type;" @@ -79,7 +78,6 @@ createConfigTables :: AppContextM Int64 createConfigTables = do createTcOrganizationTable createTcAuthenticationTable - createTcInternalAuthenticationOpenIdTable createTcPrivacyAndSupportTable createTcDashboardAndLoginScreenTable createTcDashboardAndLoginScreenAnnouncementTable @@ -124,35 +122,15 @@ createTcAuthenticationTable = do \ internal_two_factor_auth_code_expiration int NOT NULL, \ \ created_at timestamptz NOT NULL, \ \ updated_at timestamptz NOT NULL, \ + \ internal_non_admin_login_enabled bool NOT NULL, \ + \ internal_session_expiration bigint NOT NULL, \ + \ internal_user_email_link_expiration bigint NOT NULL, \ \ CONSTRAINT config_authentication_pk PRIMARY KEY (tenant_uuid), \ \ CONSTRAINT config_authentication_tenant_uuid_fk FOREIGN KEY (tenant_uuid) REFERENCES tenant (uuid) ON DELETE CASCADE \ \);" let action conn = execute_ conn sql runDB action -createTcInternalAuthenticationOpenIdTable = do - logInfo _CMP_MIGRATION "(Table/ConfigInternalAuthenticationOpenId) create tables" - let sql = - "CREATE TABLE config_authentication_openid \ - \( \ - \ id varchar NOT NULL, \ - \ name varchar NOT NULL, \ - \ url varchar NOT NULL, \ - \ client_id varchar NOT NULL, \ - \ client_secret varchar NOT NULL, \ - \ parameters jsonb NOT NULL, \ - \ style_icon varchar, \ - \ style_background varchar, \ - \ style_color varchar, \ - \ tenant_uuid uuid NOT NULL, \ - \ created_at timestamptz NOT NULL, \ - \ updated_at timestamptz NOT NULL, \ - \ CONSTRAINT config_authentication_openid_pk PRIMARY KEY (id, tenant_uuid), \ - \ CONSTRAINT config_authentication_openid_tenant_uuid_fk FOREIGN KEY (tenant_uuid) REFERENCES tenant (uuid) ON DELETE CASCADE \ - \);" - let action conn = execute_ conn sql - runDB action - createTcPrivacyAndSupportTable = do logInfo _CMP_MIGRATION "(Table/ConfigPrivacyAndSupport) create tables" let sql = @@ -386,10 +364,11 @@ createTcMailTable = do let sql = "CREATE TABLE config_mail \ \( \ - \ tenant_uuid uuid NOT NULL, \ - \ config_uuid uuid, \ - \ created_at timestamptz NOT NULL, \ - \ updated_at timestamptz NOT NULL, \ + \ tenant_uuid uuid NOT NULL, \ + \ config_uuid uuid, \ + \ created_at timestamptz NOT NULL, \ + \ updated_at timestamptz NOT NULL, \ + \ custom_templates bool NOT NULL, \ \ CONSTRAINT config_mail_pk PRIMARY KEY (tenant_uuid), \ \ CONSTRAINT config_mail_config_uuid_fk FOREIGN KEY (config_uuid) REFERENCES instance_config_mail (uuid) ON DELETE SET NULL, \ \ CONSTRAINT config_mail_tenant_uuid_fk FOREIGN KEY (tenant_uuid) REFERENCES tenant (uuid) ON DELETE CASCADE \ diff --git a/wizard-server/src/Wizard/Database/Migration/Development/User/Data/AlbertEinstein.hs b/wizard-server/src/Wizard/Database/Migration/Development/User/Data/AlbertEinstein.hs index dc49537b7..98b53be9b 100644 --- a/wizard-server/src/Wizard/Database/Migration/Development/User/Data/AlbertEinstein.hs +++ b/wizard-server/src/Wizard/Database/Migration/Development/User/Data/AlbertEinstein.hs @@ -42,7 +42,6 @@ userAlbert = , lastName = "Einstein" , email = "albert.einstein@example.com" , affiliation = Just "My University" - , sources = [_USER_SOURCE_INTERNAL] , uRole = _USER_ROLE_ADMIN , permissions = [ "TENANT_PERM" @@ -75,6 +74,8 @@ userAlbert = , lastVisitedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 , createdAt = UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 , updatedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 25) 0 + , emailVerifiedAt = Just $ UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 + , emailPending = Nothing } userAlbertEdited :: User @@ -86,6 +87,14 @@ userAlbertEdited = , affiliation = Just "EDITED: My University" } +userAlbertEditedAfterPut :: User +userAlbertEditedAfterPut = + userAlbertEdited + { email = userAlbert.email + , emailVerifiedAt = Nothing + , emailPending = Just userAlbertEdited.email + } + userAlbertWithNewsId :: User userAlbertWithNewsId = userAlbert diff --git a/wizard-server/src/Wizard/Database/Migration/Development/User/Data/CharlesDarwin.hs b/wizard-server/src/Wizard/Database/Migration/Development/User/Data/CharlesDarwin.hs index bd20dbe42..9d738b93a 100644 --- a/wizard-server/src/Wizard/Database/Migration/Development/User/Data/CharlesDarwin.hs +++ b/wizard-server/src/Wizard/Database/Migration/Development/User/Data/CharlesDarwin.hs @@ -21,7 +21,6 @@ userCharles = , lastName = "Darwin" , email = "charles.darwin@example.com" , affiliation = Nothing - , sources = [_USER_SOURCE_INTERNAL] , uRole = _USER_ROLE_RESEARCHER , permissions = ["PM_READ_PERM", "PRJ_PERM", "DOC_TML_READ_PERM", "SUBM_PERM"] , active = True @@ -36,6 +35,8 @@ userCharles = , lastVisitedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 21) 0 , createdAt = UTCTime (fromJust $ fromGregorianValid 2018 1 21) 0 , updatedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 21) 0 + , emailVerifiedAt = Just $ UTCTime (fromJust $ fromGregorianValid 2018 1 21) 0 + , emailPending = Nothing } userCharlesPluginSettings :: UserPluginSettings diff --git a/wizard-server/src/Wizard/Database/Migration/Development/User/Data/GalileoGalilei.hs b/wizard-server/src/Wizard/Database/Migration/Development/User/Data/GalileoGalilei.hs index 29a5fcf80..44fa723d8 100644 --- a/wizard-server/src/Wizard/Database/Migration/Development/User/Data/GalileoGalilei.hs +++ b/wizard-server/src/Wizard/Database/Migration/Development/User/Data/GalileoGalilei.hs @@ -16,7 +16,6 @@ userGalileo = , lastName = "Galileo" , email = "galileo.galileo@example.com" , affiliation = Nothing - , sources = [_USER_SOURCE_INTERNAL] , uRole = _USER_ROLE_RESEARCHER , permissions = ["PM_READ_PERM", "PRJ_PERM", "DOC_TML_READ_PERM", "SUBM_PERM"] , active = True @@ -31,4 +30,6 @@ userGalileo = , lastVisitedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 21) 0 , createdAt = UTCTime (fromJust $ fromGregorianValid 2018 1 21) 0 , updatedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 21) 0 + , emailVerifiedAt = Just $ UTCTime (fromJust $ fromGregorianValid 2018 1 21) 0 + , emailPending = Nothing } diff --git a/wizard-server/src/Wizard/Database/Migration/Development/User/Data/IsaacNewton.hs b/wizard-server/src/Wizard/Database/Migration/Development/User/Data/IsaacNewton.hs index 48df9fede..80fd98d53 100644 --- a/wizard-server/src/Wizard/Database/Migration/Development/User/Data/IsaacNewton.hs +++ b/wizard-server/src/Wizard/Database/Migration/Development/User/Data/IsaacNewton.hs @@ -23,7 +23,6 @@ userIsaac = , lastName = "Newton" , email = "isaac.newton@example.com" , affiliation = Nothing - , sources = [_USER_SOURCE_INTERNAL] , uRole = _USER_ROLE_RESEARCHER , permissions = ["PM_READ_PERM", "PRJ_PERM", "DOC_TML_READ_PERM", "SUBM_PERM"] , active = True @@ -38,6 +37,8 @@ userIsaac = , lastVisitedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 22) 0 , createdAt = UTCTime (fromJust $ fromGregorianValid 2018 1 22) 0 , updatedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 22) 0 + , emailVerifiedAt = Just $ UTCTime (fromJust $ fromGregorianValid 2018 1 22) 0 + , emailPending = Nothing } userIsaacEdited :: User diff --git a/wizard-server/src/Wizard/Database/Migration/Development/User/Data/NicolausCopernicus.hs b/wizard-server/src/Wizard/Database/Migration/Development/User/Data/NicolausCopernicus.hs index 3c2ac9e98..94b98893a 100644 --- a/wizard-server/src/Wizard/Database/Migration/Development/User/Data/NicolausCopernicus.hs +++ b/wizard-server/src/Wizard/Database/Migration/Development/User/Data/NicolausCopernicus.hs @@ -16,7 +16,6 @@ userNicolaus = , lastName = "Copernicus" , email = "nicolaus.copernicus@example.com" , affiliation = Nothing - , sources = [_USER_SOURCE_INTERNAL] , uRole = _USER_ROLE_RESEARCHER , permissions = ["PM_READ_PERM", "PRJ_PERM", "DOC_TML_READ_PERM", "SUBM_PERM"] , active = True @@ -31,4 +30,6 @@ userNicolaus = , lastVisitedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 25) 0 , createdAt = UTCTime (fromJust $ fromGregorianValid 2018 1 25) 0 , updatedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 25) 0 + , emailVerifiedAt = Just $ UTCTime (fromJust $ fromGregorianValid 2018 1 25) 0 + , emailPending = Nothing } diff --git a/wizard-server/src/Wizard/Database/Migration/Development/User/Data/NikolaTesla.hs b/wizard-server/src/Wizard/Database/Migration/Development/User/Data/NikolaTesla.hs index 4404b7eae..6b266ca45 100644 --- a/wizard-server/src/Wizard/Database/Migration/Development/User/Data/NikolaTesla.hs +++ b/wizard-server/src/Wizard/Database/Migration/Development/User/Data/NikolaTesla.hs @@ -23,7 +23,6 @@ userNikola = , lastName = "Tesla" , email = "nikola.tesla@example.com" , affiliation = Nothing - , sources = [_USER_SOURCE_INTERNAL] , uRole = _USER_ROLE_DATA_STEWARD , permissions = [ "KM_PERM" @@ -49,6 +48,8 @@ userNikola = , lastVisitedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 26) 0 , createdAt = UTCTime (fromJust $ fromGregorianValid 2018 1 26) 0 , updatedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 26) 0 + , emailVerifiedAt = Just $ UTCTime (fromJust $ fromGregorianValid 2018 1 26) 0 + , emailPending = Nothing } userNikolaBioGroupMembership :: UserGroupMembership diff --git a/wizard-server/src/Wizard/Database/Migration/Development/User/Data/SystemUser.hs b/wizard-server/src/Wizard/Database/Migration/Development/User/Data/SystemUser.hs index 34832397b..11d598875 100644 --- a/wizard-server/src/Wizard/Database/Migration/Development/User/Data/SystemUser.hs +++ b/wizard-server/src/Wizard/Database/Migration/Development/User/Data/SystemUser.hs @@ -16,7 +16,6 @@ userSystem = , lastName = "User" , email = "system@example.com" , affiliation = Nothing - , sources = [_USER_SOURCE_INTERNAL] , uRole = _USER_ROLE_ADMIN , permissions = [ "TENANT_PERM" @@ -49,4 +48,6 @@ userSystem = , lastVisitedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 , createdAt = UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 , updatedAt = UTCTime (fromJust $ fromGregorianValid 2018 1 25) 0 + , emailVerifiedAt = Just $ UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 + , emailPending = Nothing } diff --git a/wizard-server/src/Wizard/Database/Migration/Development/User/UserSchemaMigration.hs b/wizard-server/src/Wizard/Database/Migration/Development/User/UserSchemaMigration.hs index 68db17f96..69a510e2f 100644 --- a/wizard-server/src/Wizard/Database/Migration/Development/User/UserSchemaMigration.hs +++ b/wizard-server/src/Wizard/Database/Migration/Development/User/UserSchemaMigration.hs @@ -43,7 +43,6 @@ createUserTable = do \ email varchar NOT NULL, \ \ password_hash varchar NOT NULL, \ \ affiliation varchar, \ - \ sources varchar[] NOT NULL, \ \ role varchar NOT NULL, \ \ permissions text[] NOT NULL, \ \ active boolean NOT NULL, \ @@ -55,6 +54,8 @@ createUserTable = do \ machine boolean NOT NULL, \ \ locale uuid, \ \ last_seen_news_id varchar, \ + \ email_verified_at timestamptz, \ + \ email_pending varchar, \ \ CONSTRAINT user_entity_pk PRIMARY KEY (uuid), \ \ CONSTRAINT user_entity_tenant_uuid_fk FOREIGN KEY (tenant_uuid) REFERENCES tenant (uuid) ON DELETE CASCADE \ \); \ diff --git a/wizard-server/src/Wizard/Database/Migration/Development/ActionKey/Data/ActionKeys.hs b/wizard-server/src/Wizard/Database/Migration/Development/UserEmailLink/Data/UserEmailLinks.hs similarity index 60% rename from wizard-server/src/Wizard/Database/Migration/Development/ActionKey/Data/ActionKeys.hs rename to wizard-server/src/Wizard/Database/Migration/Development/UserEmailLink/Data/UserEmailLinks.hs index 3c15b99d3..58bd86d17 100644 --- a/wizard-server/src/Wizard/Database/Migration/Development/ActionKey/Data/ActionKeys.hs +++ b/wizard-server/src/Wizard/Database/Migration/Development/UserEmailLink/Data/UserEmailLinks.hs @@ -1,45 +1,45 @@ -module Wizard.Database.Migration.Development.ActionKey.Data.ActionKeys where +module Wizard.Database.Migration.Development.UserEmailLink.Data.UserEmailLinks where import Data.Maybe (fromJust) import Data.Time -import Shared.ActionKey.Api.Resource.ActionKey.ActionKeyDTO -import Shared.ActionKey.Model.ActionKey.ActionKey import Shared.Common.Util.Uuid +import Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkDTO +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink import Wizard.Database.Migration.Development.Tenant.Data.Tenants import Wizard.Database.Migration.Development.User.Data.Users -import Wizard.Model.ActionKey.ActionKeyType import Wizard.Model.Tenant.Tenant import Wizard.Model.User.User +import Wizard.Model.UserEmailLink.UserEmailLinkType -registrationActionKey = - ActionKey +registrationUserEmailLink = + UserEmailLink { uuid = u' "23f934f2-05b2-45d3-bce9-7675c3f3e5e9" , identity = userAlbert.uuid - , aType = RegistrationActionKey + , aType = RegistrationUserEmailLinkType , hash = "1ba90a0f-845e-41c7-9f1c-a55fc5a0554a" , tenantUuid = defaultTenant.uuid , createdAt = UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 } -forgottenPasswordActionKey = - ActionKey +forgottenPasswordUserEmailLink = + UserEmailLink { uuid = u' "23f934f2-05b2-45d3-bce9-7675c3f3e5e9" , identity = userAlbert.uuid - , aType = ForgottenPasswordActionKey + , aType = ForgottenPasswordUserEmailLinkType , hash = "1ba90a0f-845e-41c7-9f1c-a55fc5a0554a" , tenantUuid = defaultTenant.uuid , createdAt = UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 } -forgottenPasswordActionKeyDto = - ActionKeyDTO {aType = forgottenPasswordActionKey.aType, email = userAlbert.email} +forgottenPasswordUserEmailLinkDto = + UserEmailLinkDTO {aType = forgottenPasswordUserEmailLink.aType, email = userAlbert.email} -differentActionKey = - ActionKey +differentUserEmailLink = + UserEmailLink { uuid = u' "61feb6c8-3be6-4095-b2e8-7e63dcfd1f31" , identity = userCharles.uuid - , aType = RegistrationActionKey + , aType = RegistrationUserEmailLinkType , hash = "b2da34b1-35b2-408b-8127-b0ab3b8b04d9" , tenantUuid = differentTenant.uuid , createdAt = UTCTime (fromJust $ fromGregorianValid 2018 1 20) 0 diff --git a/wizard-server/src/Wizard/Database/Migration/Development/UserEmailLink/UserEmailLinkMigration.hs b/wizard-server/src/Wizard/Database/Migration/Development/UserEmailLink/UserEmailLinkMigration.hs new file mode 100644 index 000000000..e74c277d3 --- /dev/null +++ b/wizard-server/src/Wizard/Database/Migration/Development/UserEmailLink/UserEmailLinkMigration.hs @@ -0,0 +1,16 @@ +module Wizard.Database.Migration.Development.UserEmailLink.UserEmailLinkMigration where + +import Shared.Common.Constant.Component +import Shared.Common.Util.Logger +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO +import Wizard.Database.Mapping.UserEmailLink.UserEmailLinkType () +import Wizard.Database.Migration.Development.UserEmailLink.Data.UserEmailLinks +import Wizard.Model.Context.AppContext +import Wizard.Model.Context.ContextLenses () + +runMigration :: AppContextM () +runMigration = do + logInfo _CMP_MIGRATION "(UserEmailLink/UserEmailLink) started" + deleteUserEmailLinks + insertUserEmailLink differentUserEmailLink + logInfo _CMP_MIGRATION "(UserEmailLink/UserEmailLink) ended" diff --git a/wizard-server/src/Wizard/Database/Migration/Development/ActionKey/ActionKeySchemaMigration.hs b/wizard-server/src/Wizard/Database/Migration/Development/UserEmailLink/UserEmailLinkSchemaMigration.hs similarity index 51% rename from wizard-server/src/Wizard/Database/Migration/Development/ActionKey/ActionKeySchemaMigration.hs rename to wizard-server/src/Wizard/Database/Migration/Development/UserEmailLink/UserEmailLinkSchemaMigration.hs index db832806e..b9a1f7b9f 100644 --- a/wizard-server/src/Wizard/Database/Migration/Development/ActionKey/ActionKeySchemaMigration.hs +++ b/wizard-server/src/Wizard/Database/Migration/Development/UserEmailLink/UserEmailLinkSchemaMigration.hs @@ -1,4 +1,4 @@ -module Wizard.Database.Migration.Development.ActionKey.ActionKeySchemaMigration where +module Wizard.Database.Migration.Development.UserEmailLink.UserEmailLinkSchemaMigration where import Database.PostgreSQL.Simple import GHC.Int @@ -10,16 +10,16 @@ import Wizard.Model.Context.ContextLenses () dropTables :: AppContextM Int64 dropTables = do - logInfo _CMP_MIGRATION "(Table/ActionKey) drop tables" - let sql = "DROP TABLE IF EXISTS action_key CASCADE;" + logInfo _CMP_MIGRATION "(Table/UserEmailLink) drop tables" + let sql = "DROP TABLE IF EXISTS user_email_link CASCADE;" let action conn = execute_ conn sql runDB action createTables :: AppContextM Int64 createTables = do - logInfo _CMP_MIGRATION "(Table/ActionKey) create table" + logInfo _CMP_MIGRATION "(Table/UserEmailLink) create table" let sql = - "CREATE TABLE action_key \ + "CREATE TABLE user_email_link \ \( \ \ uuid uuid NOT NULL, \ \ identity uuid NOT NULL, \ @@ -27,11 +27,11 @@ createTables = do \ hash varchar NOT NULL, \ \ created_at timestamptz NOT NULL, \ \ tenant_uuid uuid NOT NULL, \ - \ CONSTRAINT action_key_pk PRIMARY KEY (uuid), \ - \ CONSTRAINT action_key_identity_fk FOREIGN KEY (identity) REFERENCES user_entity (uuid) ON DELETE CASCADE, \ - \ CONSTRAINT action_key_tenant_uuid_fk FOREIGN KEY (tenant_uuid) REFERENCES tenant (uuid) ON DELETE CASCADE \ + \ CONSTRAINT user_email_link_pk PRIMARY KEY (uuid), \ + \ CONSTRAINT user_email_link_identity_fk FOREIGN KEY (identity) REFERENCES user_entity (uuid) ON DELETE CASCADE, \ + \ CONSTRAINT user_email_link_tenant_uuid_fk FOREIGN KEY (tenant_uuid) REFERENCES tenant (uuid) ON DELETE CASCADE \ \); \ \ \ - \CREATE UNIQUE INDEX action_key_hash_uindex ON action_key (hash);" + \CREATE UNIQUE INDEX user_email_link_hash_uindex ON user_email_link (hash);" let action conn = execute_ conn sql runDB action diff --git a/wizard-server/src/Wizard/Database/Migration/Production/Migration.hs b/wizard-server/src/Wizard/Database/Migration/Production/Migration.hs index f10b01fa8..96c71ccd5 100644 --- a/wizard-server/src/Wizard/Database/Migration/Production/Migration.hs +++ b/wizard-server/src/Wizard/Database/Migration/Production/Migration.hs @@ -68,6 +68,7 @@ import qualified Wizard.Database.Migration.Production.Migration_0063_plugins.Mig import qualified Wizard.Database.Migration.Production.Migration_0064_prjTmpPerm.Migration as M_0064 import qualified Wizard.Database.Migration.Production.Migration_0065_idToUuid.Migration as M_0065 import qualified Wizard.Database.Migration.Production.Migration_0066_tcKnowledgeModel.Migration as M_0066 +import qualified Wizard.Database.Migration.Production.Migration_0067_openIdClient.Migration as M_0067 migrationDefinitions :: [MigrationDefinition] migrationDefinitions = @@ -137,4 +138,5 @@ migrationDefinitions = , M_0064.definition , M_0065.definition , M_0066.definition + , M_0067.definition ] diff --git a/wizard-server/src/Wizard/Database/Migration/Production/Migration_0067_openIdClient/Migration.hs b/wizard-server/src/Wizard/Database/Migration/Production/Migration_0067_openIdClient/Migration.hs new file mode 100644 index 000000000..63d3ad1cd --- /dev/null +++ b/wizard-server/src/Wizard/Database/Migration/Production/Migration_0067_openIdClient/Migration.hs @@ -0,0 +1,180 @@ +module Wizard.Database.Migration.Production.Migration_0067_openIdClient.Migration ( + definition, +) where + +import Control.Monad.Logger +import Control.Monad.Reader (liftIO) +import Data.Pool (Pool, withResource) +import Database.PostgreSQL.Migration.Entity +import Database.PostgreSQL.Simple + +definition = (meta, migrate) + +meta = MigrationMeta {mmNumber = 67, mmName = "OpenID Client", mmDescription = "Promote OpenID configuration to a first-class entity with UUID PK, scope flags and registrationEnabled. Add user_openid_identity link table, user_registration_pending table, and email verification columns on user_entity; drop legacy config_authentication_openid + user_entity.sources. Add per-tenant session and user email link expiration to config_authentication."} + +migrate :: Pool Connection -> LoggingT IO (Maybe Error) +migrate dbPool = do + createOpenIdClientTable dbPool + prepareLegacyMapping dbPool + copyOpenIdClientData dbPool + createUserOpenIdIdentityTable dbPool + createUserRegistrationPendingTable dbPool + addUserEmailVerification dbPool + dropLegacyOpenIdConfig dbPool + addNonAdminLoginEnabled dbPool + addConfigMailCustomTemplates dbPool + addAuthExpirationColumns dbPool + renameUserEmailLinkTable dbPool + +createOpenIdClientTable dbPool = do + let sql = + "CREATE TABLE openid_client \ + \( \ + \ uuid uuid NOT NULL, \ + \ name varchar NOT NULL, \ + \ url varchar NOT NULL, \ + \ client_id varchar NOT NULL, \ + \ client_secret varchar NOT NULL, \ + \ parameters jsonb NOT NULL, \ + \ style jsonb NOT NULL, \ + \ tenant_uuid uuid NOT NULL, \ + \ created_at timestamptz NOT NULL, \ + \ updated_at timestamptz NOT NULL, \ + \ registration_enabled bool NOT NULL, \ + \ scope_profile bool NOT NULL, \ + \ scope_email bool NOT NULL, \ + \ CONSTRAINT openid_client_pk PRIMARY KEY (uuid), \ + \ CONSTRAINT openid_client_tenant_uuid_fk FOREIGN KEY (tenant_uuid) REFERENCES tenant (uuid) ON DELETE CASCADE \ + \);" + let action conn = execute_ conn sql + liftIO $ withResource dbPool action + return Nothing + +prepareLegacyMapping dbPool = do + let sql = + "ALTER TABLE config_authentication_openid ADD COLUMN _new_uuid uuid; \ + \UPDATE config_authentication_openid SET _new_uuid = gen_random_uuid();" + let action conn = execute_ conn sql + liftIO $ withResource dbPool action + return Nothing + +copyOpenIdClientData dbPool = do + let sql = + "INSERT INTO openid_client \ + \ (uuid, name, url, client_id, client_secret, parameters, style, tenant_uuid, created_at, updated_at, registration_enabled, scope_profile, scope_email) \ + \SELECT \ + \ _new_uuid, \ + \ name, \ + \ url, \ + \ client_id, \ + \ client_secret, \ + \ parameters, \ + \ jsonb_build_object('icon', style_icon, 'background', style_background, 'color', style_color), \ + \ tenant_uuid, \ + \ created_at, \ + \ updated_at, \ + \ true, \ + \ true, \ + \ true \ + \FROM config_authentication_openid;" + let action conn = execute_ conn sql + liftIO $ withResource dbPool action + return Nothing + +createUserOpenIdIdentityTable dbPool = do + let sql = + "CREATE TABLE user_openid_identity \ + \( \ + \ uuid uuid NOT NULL, \ + \ external_id varchar NOT NULL, \ + \ external_label varchar, \ + \ user_uuid uuid NOT NULL, \ + \ provider_uuid uuid NOT NULL, \ + \ tenant_uuid uuid NOT NULL, \ + \ created_at timestamptz NOT NULL, \ + \ CONSTRAINT user_openid_identity_pk PRIMARY KEY (uuid), \ + \ CONSTRAINT user_openid_identity_user_uuid_fk FOREIGN KEY (user_uuid) REFERENCES user_entity (uuid) ON DELETE CASCADE, \ + \ CONSTRAINT user_openid_identity_provider_uuid_fk FOREIGN KEY (provider_uuid) REFERENCES openid_client (uuid) ON DELETE CASCADE, \ + \ CONSTRAINT user_openid_identity_tenant_uuid_fk FOREIGN KEY (tenant_uuid) REFERENCES tenant (uuid) ON DELETE CASCADE \ + \); \ + \CREATE UNIQUE INDEX user_openid_identity_uindex ON user_openid_identity (external_id, provider_uuid, tenant_uuid);" + let action conn = execute_ conn sql + liftIO $ withResource dbPool action + return Nothing + +createUserRegistrationPendingTable dbPool = do + let sql = + "CREATE TABLE user_registration_pending \ + \( \ + \ uuid uuid NOT NULL, \ + \ hash varchar NOT NULL, \ + \ service_type varchar NOT NULL, \ + \ provider_uuid uuid NOT NULL, \ + \ external_id varchar NOT NULL, \ + \ external_label varchar, \ + \ email varchar, \ + \ first_name varchar, \ + \ last_name varchar, \ + \ image_url varchar, \ + \ affiliation varchar, \ + \ tenant_uuid uuid NOT NULL, \ + \ created_at timestamptz NOT NULL, \ + \ CONSTRAINT user_registration_pending_pk PRIMARY KEY (uuid), \ + \ CONSTRAINT user_registration_pending_tenant_uuid_fk FOREIGN KEY (tenant_uuid) REFERENCES tenant (uuid) ON DELETE CASCADE \ + \); \ + \CREATE UNIQUE INDEX user_registration_pending_hash_uindex ON user_registration_pending (hash, tenant_uuid);" + let action conn = execute_ conn sql + liftIO $ withResource dbPool action + return Nothing + +addUserEmailVerification dbPool = do + let sql = + "ALTER TABLE user_entity ADD COLUMN email_verified_at timestamptz; \ + \ALTER TABLE user_entity ADD COLUMN email_pending varchar; \ + \UPDATE user_entity SET email_verified_at = created_at WHERE email_verified_at IS NULL;" + let action conn = execute_ conn sql + liftIO $ withResource dbPool action + return Nothing + +dropLegacyOpenIdConfig dbPool = do + let sql = + "ALTER TABLE user_entity DROP COLUMN sources; \ + \DROP TABLE config_authentication_openid;" + let action conn = execute_ conn sql + liftIO $ withResource dbPool action + return Nothing + +addNonAdminLoginEnabled dbPool = do + let sql = "ALTER TABLE config_authentication ADD COLUMN IF NOT EXISTS internal_non_admin_login_enabled bool NOT NULL DEFAULT true;" + let action conn = execute_ conn sql + liftIO $ withResource dbPool action + return Nothing + +addConfigMailCustomTemplates dbPool = do + let sql = "ALTER TABLE config_mail ADD COLUMN custom_templates bool NOT NULL DEFAULT false;" + let action conn = execute_ conn sql + liftIO $ withResource dbPool action + return Nothing + +addAuthExpirationColumns dbPool = do + let sql = + "ALTER TABLE config_authentication ADD COLUMN IF NOT EXISTS internal_session_expiration bigint NOT NULL DEFAULT 336; \ + \ALTER TABLE config_authentication ADD COLUMN IF NOT EXISTS internal_user_email_link_expiration bigint NOT NULL DEFAULT 336;" + let action conn = execute_ conn sql + liftIO $ withResource dbPool action + return Nothing + +renameUserEmailLinkTable dbPool = do + let sql = + "ALTER TABLE IF EXISTS action_key RENAME TO user_email_link; \ + \ALTER TABLE IF EXISTS user_email_link RENAME CONSTRAINT action_key_pk TO user_email_link_pk; \ + \ALTER TABLE IF EXISTS user_email_link RENAME CONSTRAINT action_key_identity_fk TO user_email_link_identity_fk; \ + \ALTER TABLE IF EXISTS user_email_link RENAME CONSTRAINT action_key_tenant_uuid_fk TO user_email_link_tenant_uuid_fk; \ + \UPDATE user_email_link SET type = 'RegistrationUserEmailLinkType' WHERE type = 'RegistrationActionKey'; \ + \UPDATE user_email_link SET type = 'ForgottenPasswordUserEmailLinkType' WHERE type = 'ForgottenPasswordActionKey'; \ + \UPDATE user_email_link SET type = 'TwoFactorAuthUserEmailLinkType' WHERE type = 'TwoFactorAuthActionKey'; \ + \UPDATE user_email_link SET type = 'ConsentsRequiredUserEmailLinkType' WHERE type = 'ConsentsRequiredActionKey'; \ + \UPDATE user_email_link SET type = 'EmailChangeUserEmailLinkType' WHERE type = 'EmailChangeActionKey';" + let action conn = execute_ conn sql + liftIO $ withResource dbPool action + return Nothing diff --git a/wizard-server/src/Wizard/Integration/Http/TypeHint/ResponseMapper.hs b/wizard-server/src/Wizard/Integration/Http/TypeHint/ResponseMapper.hs index d01edcfbc..1a71a68bd 100644 --- a/wizard-server/src/Wizard/Integration/Http/TypeHint/ResponseMapper.hs +++ b/wizard-server/src/Wizard/Integration/Http/TypeHint/ResponseMapper.hs @@ -36,12 +36,16 @@ toRetrieveTypeHintsResponse intConfig response = do valuesForSelect <- case intConfig.responseItemTemplateForSelection of Just templateForSelection -> (fmap . fmap . fmap $ Just) $ renderJinjaBatch templateForSelection recordsInItems Nothing -> return $ fmap (const (Right Nothing)) recordsInItems - return . Right . rights . fmap mapRecord $ zip3 valuesForSelect values records' + return . Right . rights . fmap mapRecord . filter filterRecord $ zip3 valuesForSelect values records' where listField = case intConfig.responseListField of Just responseListField -> splitOn "." responseListField Nothing -> [] + filterRecord :: (Either String (Maybe String), Either String String, Value) -> Bool + filterRecord (_, Right "", _) = False + filterRecord (Right (Just ""), _, _) = False + filterRecord _ = True mapRecord :: (Either String (Maybe String), Either String String, Value) -> Either String TypeHintIDTO mapRecord (Left err, _, _) = Left err mapRecord (_, Left err, _) = Left err diff --git a/wizard-server/src/Wizard/Localization/Messages/Public.hs b/wizard-server/src/Wizard/Localization/Messages/Public.hs index 59b61cb7a..2c19dcade 100644 --- a/wizard-server/src/Wizard/Localization/Messages/Public.hs +++ b/wizard-server/src/Wizard/Localization/Messages/Public.hs @@ -84,6 +84,9 @@ _ERROR_SERVICE_DOCUMENT__PROJECT_OR_FORMAT_NOT_SET_UP = _ERROR_SERVICE_AUTH__SERVICE_NOT_DEFINED authId = LocaleRecord "error.service.auth.service_not_defined" "Service '%s' is not defined" [authId] +_ERROR_VALIDATION__USER_EMAIL_FROM_IDP_CANNOT_BE_CHANGED = + LocaleRecord "error.validation.user_email_from_idp_cannot_be_changed" "Email provided by the OpenID provider cannot be changed" [] + -- Knowledge Model Editor _ERROR_SERVICE_KNOWLEDGE_MODEL_EDITOR__KM_MIGRATION_EXISTS = LocaleRecord "error.service.knowledge_model_editor.km_migration_exists" "You can't publish the KM editor when there is ongoing KM migration" [] diff --git a/wizard-server/src/Wizard/Model/ActionKey/ActionKeyType.hs b/wizard-server/src/Wizard/Model/ActionKey/ActionKeyType.hs deleted file mode 100644 index 0a7ebba98..000000000 --- a/wizard-server/src/Wizard/Model/ActionKey/ActionKeyType.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Wizard.Model.ActionKey.ActionKeyType where - -import GHC.Generics - -data ActionKeyType - = RegistrationActionKey - | ForgottenPasswordActionKey - | TwoFactorAuthActionKey - | ConsentsRequiredActionKey - deriving (Show, Eq, Generic, Read) diff --git a/wizard-server/src/Wizard/Model/Config/ServerConfig.hs b/wizard-server/src/Wizard/Model/Config/ServerConfig.hs index ad3dc0e7b..9cf246d34 100644 --- a/wizard-server/src/Wizard/Model/Config/ServerConfig.hs +++ b/wizard-server/src/Wizard/Model/Config/ServerConfig.hs @@ -12,9 +12,8 @@ data ServerConfig = ServerConfig , s3 :: ServerConfigS3 , aws :: ServerConfigAws , sentry :: ServerConfigSentry - , jwt :: ServerConfigJwt , roles :: ServerConfigRoles - , actionKey :: ServerConfigActionKey + , userEmailLink :: ServerConfigUserEmailLink , cache :: ServerConfigCache , document :: ServerConfigDocument , externalLink :: ServerConfigExternalLink @@ -26,7 +25,6 @@ data ServerConfig = ServerConfig , analyticalMails :: ServerConfigAnalyticalMails , logging :: ServerConfigLogging , cloud :: ServerConfigCloud - , plan :: ServerConfigPlan , persistentCommand :: ServerConfigPersistentCommand , signalBridge :: ServerConfigSignalBridge , admin :: ServerConfigAdmin @@ -52,7 +50,7 @@ data ServerConfigRoles = ServerConfigRoles } deriving (Generic, Show) -data ServerConfigActionKey = ServerConfigActionKey +data ServerConfigUserEmailLink = ServerConfigUserEmailLink { clean :: ServerConfigCronWorker } deriving (Generic, Show) diff --git a/wizard-server/src/Wizard/Model/Config/ServerConfigDM.hs b/wizard-server/src/Wizard/Model/Config/ServerConfigDM.hs index b40f04206..ea99628d7 100644 --- a/wizard-server/src/Wizard/Model/Config/ServerConfigDM.hs +++ b/wizard-server/src/Wizard/Model/Config/ServerConfigDM.hs @@ -15,9 +15,8 @@ defaultConfig = , s3 = defaultS3 , aws = defaultAws , sentry = defaultSentry - , jwt = defaultJwt , roles = defaultRoles - , actionKey = defaultActionKey + , userEmailLink = defaultUserEmailLink , cache = defaultCache , document = defaultDocument , externalLink = defaultExternalLink @@ -29,7 +28,6 @@ defaultConfig = , analyticalMails = defaultAnalyticalMails , logging = defaultLogging , cloud = defaultCloud - , plan = defaultPlan , persistentCommand = defaultPersistentCommand , signalBridge = defaultSignalBridge , admin = defaultAdmin @@ -87,12 +85,12 @@ defaultRegistrySyncJob :: ServerConfigCronWorker defaultRegistrySyncJob = ServerConfigCronWorker {enabled = True, cron = registrySyncWorker.cronDefault} -defaultActionKey :: ServerConfigActionKey -defaultActionKey = ServerConfigActionKey {clean = defaultActionKeyClean} +defaultUserEmailLink :: ServerConfigUserEmailLink +defaultUserEmailLink = ServerConfigUserEmailLink {clean = defaultUserEmailLinkClean} -defaultActionKeyClean :: ServerConfigCronWorker -defaultActionKeyClean = - ServerConfigCronWorker {enabled = True, cron = actionKeyWorker.cronDefault} +defaultUserEmailLinkClean :: ServerConfigCronWorker +defaultUserEmailLinkClean = + ServerConfigCronWorker {enabled = True, cron = userEmailLinkWorker.cronDefault} defaultCache :: ServerConfigCache defaultCache = diff --git a/wizard-server/src/Wizard/Model/Config/ServerConfigIM.hs b/wizard-server/src/Wizard/Model/Config/ServerConfigIM.hs index f81fe1ae4..11d84260e 100644 --- a/wizard-server/src/Wizard/Model/Config/ServerConfigIM.hs +++ b/wizard-server/src/Wizard/Model/Config/ServerConfigIM.hs @@ -12,9 +12,8 @@ instance FromEnv ServerConfig where s3 <- applyEnv serverConfig.s3 aws <- applyEnv serverConfig.aws sentry <- applyEnv serverConfig.sentry - jwt <- applyEnv serverConfig.jwt roles <- applyEnv serverConfig.roles - actionKey <- applyEnv serverConfig.actionKey + userEmailLink <- applyEnv serverConfig.userEmailLink cache <- applyEnv serverConfig.cache document <- applyEnv serverConfig.document externalLink <- applyEnv serverConfig.externalLink @@ -26,7 +25,6 @@ instance FromEnv ServerConfig where analyticalMails <- applyEnv serverConfig.analyticalMails logging <- applyEnv serverConfig.logging cloud <- applyEnv serverConfig.cloud - plan <- applyEnv serverConfig.plan persistentCommand <- applyEnv serverConfig.persistentCommand signalBridge <- applyEnv serverConfig.signalBridge admin <- applyEnv serverConfig.admin @@ -55,12 +53,12 @@ instance FromEnv ServerConfigRoles where , \c -> applyEnvVariable "ROLES_RESEARCHER" c.researcher (\x -> c {researcher = x} :: ServerConfigRoles) ] -instance FromEnv ServerConfigActionKey where +instance FromEnv ServerConfigUserEmailLink where applyEnv serverConfig = applyEnvVariables serverConfig - [ \c -> applyEnvVariable "ACTION_KEY_CLEAN_ENABLED" c.clean.enabled (\x -> c {clean = c.clean {enabled = x}} :: ServerConfigActionKey) - , \c -> applyStringEnvVariable "ACTION_KEY_CLEAN_CRON" c.clean.cron (\x -> c {clean = c.clean {cron = x}} :: ServerConfigActionKey) + [ \c -> applyEnvVariable "USER_EMAIL_LINK_CLEAN_ENABLED" c.clean.enabled (\x -> c {clean = c.clean {enabled = x}} :: ServerConfigUserEmailLink) + , \c -> applyStringEnvVariable "USER_EMAIL_LINK_CLEAN_CRON" c.clean.cron (\x -> c {clean = c.clean {cron = x}} :: ServerConfigUserEmailLink) ] instance FromEnv ServerConfigCache where diff --git a/wizard-server/src/Wizard/Model/Config/ServerConfigJM.hs b/wizard-server/src/Wizard/Model/Config/ServerConfigJM.hs index 6b4fba6b9..d88c4570d 100644 --- a/wizard-server/src/Wizard/Model/Config/ServerConfigJM.hs +++ b/wizard-server/src/Wizard/Model/Config/ServerConfigJM.hs @@ -23,9 +23,8 @@ instance FromJSON ServerConfig where s3 <- o .:? "s3" .!= defaultS3 aws <- o .:? "aws" .!= defaultAws sentry <- o .:? "sentry" .!= defaultSentry - jwt <- o .:? "jwt" .!= defaultJwt roles <- o .:? "roles" .!= defaultRoles - actionKey <- o .:? "actionKey" .!= defaultActionKey + userEmailLink <- o .:? "userEmailLink" .!= defaultUserEmailLink knowledgeModelEditor <- o .:? "knowledgeModelEditor" .!= defaultKnowledgeModelEditor cache <- o .:? "cache" .!= defaultCache document <- o .:? "document" .!= defaultDocument @@ -37,7 +36,6 @@ instance FromJSON ServerConfig where analyticalMails <- o .:? "analyticalMails" .!= defaultAnalyticalMails logging <- o .:? "logging" .!= defaultLogging cloud <- o .:? "cloud" .!= defaultCloud - plan <- o .:? "plan" .!= defaultPlan persistentCommand <- o .:? "persistentCommand" .!= defaultPersistentCommand signalBridge <- o .:? "signalBridge" .!= defaultSignalBridge admin <- o .:? "admin" .!= defaultAdmin @@ -72,10 +70,10 @@ instance FromJSON ServerConfigRoles where return ServerConfigRoles {..} parseJSON _ = mzero -instance FromJSON ServerConfigActionKey where +instance FromJSON ServerConfigUserEmailLink where parseJSON (Object o) = do - clean <- o .:? "clean" .!= defaultActionKey.clean - return ServerConfigActionKey {..} + clean <- o .:? "clean" .!= defaultUserEmailLink.clean + return ServerConfigUserEmailLink {..} parseJSON _ = mzero instance FromJSON ServerConfigKnowledgeModelEditor where diff --git a/wizard-server/src/Wizard/Model/Project/Comment/ProjectCommentThreadNotification.hs b/wizard-server/src/Wizard/Model/Project/Comment/ProjectCommentThreadNotification.hs index 248b09696..f8e654d35 100644 --- a/wizard-server/src/Wizard/Model/Project/Comment/ProjectCommentThreadNotification.hs +++ b/wizard-server/src/Wizard/Model/Project/Comment/ProjectCommentThreadNotification.hs @@ -8,6 +8,8 @@ import WizardLib.Public.Model.User.UserSimple data ProjectCommentThreadNotification = ProjectCommentThreadNotification { projectUuid :: U.UUID , projectName :: String + , knowledgeModelPackageUuid :: U.UUID + , selectedQuestionTagUuids :: [U.UUID] , tenantUuid :: U.UUID , commentThreadUuid :: U.UUID , path :: String @@ -16,6 +18,7 @@ data ProjectCommentThreadNotification = ProjectCommentThreadNotification , assignedTo :: UserSimple , assignedBy :: Maybe UserSimple , text :: String + , questionTitle :: Maybe String , clientUrl :: String , appTitle :: Maybe String , logoUrl :: Maybe String diff --git a/wizard-server/src/Wizard/Model/Submission/Submission.hs b/wizard-server/src/Wizard/Model/Submission/Submission.hs index c47d11596..608e13223 100644 --- a/wizard-server/src/Wizard/Model/Submission/Submission.hs +++ b/wizard-server/src/Wizard/Model/Submission/Submission.hs @@ -18,7 +18,7 @@ data Submission = Submission , serviceId :: String , documentUuid :: U.UUID , tenantUuid :: U.UUID - , createdBy :: U.UUID + , createdBy :: Maybe U.UUID , createdAt :: UTCTime , updatedAt :: UTCTime } diff --git a/wizard-server/src/Wizard/Model/Submission/SubmissionList.hs b/wizard-server/src/Wizard/Model/Submission/SubmissionList.hs index 39aa0f1ac..2a72a7e79 100644 --- a/wizard-server/src/Wizard/Model/Submission/SubmissionList.hs +++ b/wizard-server/src/Wizard/Model/Submission/SubmissionList.hs @@ -15,7 +15,7 @@ data SubmissionList = SubmissionList , serviceId :: String , serviceName :: Maybe String , documentUuid :: U.UUID - , createdBy :: UserSuggestion + , createdBy :: Maybe UserSuggestion , createdAt :: UTCTime , updatedAt :: UTCTime } diff --git a/wizard-server/src/Wizard/Model/Tenant/Config/TenantConfig.hs b/wizard-server/src/Wizard/Model/Tenant/Config/TenantConfig.hs index 022e8ae86..8282d7fea 100644 --- a/wizard-server/src/Wizard/Model/Tenant/Config/TenantConfig.hs +++ b/wizard-server/src/Wizard/Model/Tenant/Config/TenantConfig.hs @@ -7,8 +7,6 @@ import qualified Data.UUID as U import GHC.Generics import Shared.Common.Model.Config.SimpleFeature -import Shared.OpenId.Model.OpenId.OpenIdClientParameter -import Shared.OpenId.Model.OpenId.OpenIdClientStyle import Wizard.Model.Project.Project hiding (uuid) import WizardLib.Public.Model.Tenant.Config.TenantConfig @@ -70,7 +68,6 @@ data TenantConfigAuthentication = TenantConfigAuthentication { tenantUuid :: U.UUID , defaultRole :: String , internal :: TenantConfigAuthenticationInternal - , external :: TenantConfigAuthenticationExternal , createdAt :: UTCTime , updatedAt :: UTCTime } @@ -81,10 +78,12 @@ instance Eq TenantConfigAuthentication where a.tenantUuid == b.tenantUuid && a.defaultRole == b.defaultRole && a.internal == b.internal - && a.external == b.external data TenantConfigAuthenticationInternal = TenantConfigAuthenticationInternal { registration :: SimpleFeature + , nonAdminLoginEnabled :: Bool + , sessionExpiration :: Integer + , userEmailLinkExpiration :: Integer , twoFactorAuth :: TenantConfigAuthenticationInternalTwoFactorAuth } deriving (Generic, Eq, Show) @@ -96,36 +95,6 @@ data TenantConfigAuthenticationInternalTwoFactorAuth = TenantConfigAuthenticatio } deriving (Generic, Eq, Show) -data TenantConfigAuthenticationExternal = TenantConfigAuthenticationExternal - { services :: [TenantConfigAuthenticationExternalService] - } - deriving (Generic, Eq, Show) - -data TenantConfigAuthenticationExternalService = TenantConfigAuthenticationExternalService - { tenantUuid :: U.UUID - , aId :: String - , name :: String - , url :: String - , clientId :: String - , clientSecret :: String - , parameters :: [OpenIdClientParameter] - , style :: OpenIdClientStyle - , createdAt :: UTCTime - , updatedAt :: UTCTime - } - deriving (Generic, Show) - -instance Eq TenantConfigAuthenticationExternalService where - a == b = - a.tenantUuid == b.tenantUuid - && a.aId == b.aId - && a.name == b.name - && a.url == b.url - && a.clientId == b.clientId - && a.clientSecret == b.clientSecret - && a.parameters == b.parameters - && a.style == b.style - data TenantConfigPrivacyAndSupport = TenantConfigPrivacyAndSupport { tenantUuid :: U.UUID , privacyUrl :: Maybe String diff --git a/wizard-server/src/Wizard/Model/Tenant/Config/TenantConfigDM.hs b/wizard-server/src/Wizard/Model/Tenant/Config/TenantConfigDM.hs index 72c704bf5..8af01ccdd 100644 --- a/wizard-server/src/Wizard/Model/Tenant/Config/TenantConfigDM.hs +++ b/wizard-server/src/Wizard/Model/Tenant/Config/TenantConfigDM.hs @@ -26,13 +26,12 @@ defaultAuthentication = { tenantUuid = U.nil , defaultRole = _USER_ROLE_RESEARCHER , internal = defaultAuthenticationInternal - , external = defaultAuthenticationExternal , createdAt = dt' 2018 1 20 , updatedAt = dt' 2018 1 20 } defaultAuthenticationInternal :: TenantConfigAuthenticationInternal -defaultAuthenticationInternal = TenantConfigAuthenticationInternal {registration = SimpleFeature True, twoFactorAuth = defaultAuthenticationInternalTwoFactorAuth} +defaultAuthenticationInternal = TenantConfigAuthenticationInternal {registration = SimpleFeature True, nonAdminLoginEnabled = True, sessionExpiration = 14 * 24, userEmailLinkExpiration = 14 * 24, twoFactorAuth = defaultAuthenticationInternalTwoFactorAuth} defaultAuthenticationInternalTwoFactorAuth :: TenantConfigAuthenticationInternalTwoFactorAuth defaultAuthenticationInternalTwoFactorAuth = @@ -42,9 +41,6 @@ defaultAuthenticationInternalTwoFactorAuth = , expiration = 600 } -defaultAuthenticationExternal :: TenantConfigAuthenticationExternal -defaultAuthenticationExternal = TenantConfigAuthenticationExternal {services = []} - defaultPrivacyAndSupport :: TenantConfigPrivacyAndSupport defaultPrivacyAndSupport = TenantConfigPrivacyAndSupport diff --git a/wizard-server/src/Wizard/Model/Tenant/Config/TenantConfigEM.hs b/wizard-server/src/Wizard/Model/Tenant/Config/TenantConfigEM.hs index 42d86d5db..1e9abab74 100644 --- a/wizard-server/src/Wizard/Model/Tenant/Config/TenantConfigEM.hs +++ b/wizard-server/src/Wizard/Model/Tenant/Config/TenantConfigEM.hs @@ -2,34 +2,16 @@ module Wizard.Model.Tenant.Config.TenantConfigEM where import Shared.Common.Model.Common.SensitiveData import Shared.Common.Util.Crypto (encryptAES256WithB64) -import Shared.OpenId.Model.OpenId.OpenIdClientParameter -import Shared.OpenId.Model.OpenId.OpenIdClientStyle import Wizard.Model.Tenant.Config.TenantConfig import WizardLib.Public.Model.Tenant.Config.TenantConfig import WizardLib.Public.Model.Tenant.Config.TenantConfigEM () instance SensitiveData TenantConfigOrganization -instance SensitiveData TenantConfigAuthentication where - process key entity = entity {external = process key entity.external} +instance SensitiveData TenantConfigAuthentication instance SensitiveData TenantConfigAuthenticationInternal -instance SensitiveData TenantConfigAuthenticationExternal where - process key entity = - entity {services = fmap (process key) entity.services} - -instance SensitiveData TenantConfigAuthenticationExternalService where - process key entity = - entity - { clientId = encryptAES256WithB64 key entity.clientId - , clientSecret = encryptAES256WithB64 key entity.clientSecret - } - -instance SensitiveData OpenIdClientParameter - -instance SensitiveData OpenIdClientStyle - instance SensitiveData TenantConfigPrivacyAndSupport instance SensitiveData TenantConfigDashboardAndLoginScreen diff --git a/wizard-server/src/Wizard/Model/User/User.hs b/wizard-server/src/Wizard/Model/User/User.hs index b3b12c9b7..0e9535e77 100644 --- a/wizard-server/src/Wizard/Model/User/User.hs +++ b/wizard-server/src/Wizard/Model/User/User.hs @@ -4,8 +4,6 @@ import Data.Time import qualified Data.UUID as U import GHC.Generics -_USER_SOURCE_INTERNAL = "internal" - _USER_ROLE_ADMIN = "admin" _USER_ROLE_DATA_STEWARD = "dataSteward" @@ -19,7 +17,6 @@ data User = User , email :: String , passwordHash :: String , affiliation :: Maybe String - , sources :: [String] , uRole :: String , permissions :: [String] , active :: Bool @@ -31,6 +28,8 @@ data User = User , lastVisitedAt :: UTCTime , createdAt :: UTCTime , updatedAt :: UTCTime + , emailVerifiedAt :: Maybe UTCTime + , emailPending :: Maybe String } deriving (Generic, Show) @@ -42,7 +41,6 @@ instance Eq User where && a.email == b.email && a.passwordHash == b.passwordHash && a.affiliation == b.affiliation - && a.sources == b.sources && a.uRole == b.uRole && a.permissions == b.permissions && a.active == b.active @@ -51,3 +49,5 @@ instance Eq User where && a.machine == b.machine && a.lastSeenNewsId == b.lastSeenNewsId && a.tenantUuid == b.tenantUuid + && a.emailVerifiedAt == b.emailVerifiedAt + && a.emailPending == b.emailPending diff --git a/wizard-server/src/Wizard/Model/User/UserProfile.hs b/wizard-server/src/Wizard/Model/User/UserProfile.hs index cf30b2a2a..55adf8360 100644 --- a/wizard-server/src/Wizard/Model/User/UserProfile.hs +++ b/wizard-server/src/Wizard/Model/User/UserProfile.hs @@ -2,6 +2,7 @@ module Wizard.Model.User.UserProfile where import qualified Data.Aeson as A import qualified Data.Map.Strict as M +import Data.Time import qualified Data.UUID as U import GHC.Generics @@ -16,5 +17,7 @@ data UserProfile = UserProfile , lastSeenNewsId :: Maybe String , userGroupUuids :: [U.UUID] , pluginSettings :: M.Map U.UUID A.Value + , emailVerifiedAt :: Maybe UTCTime + , emailPending :: Maybe String } deriving (Show, Eq, Generic) diff --git a/wizard-server/src/Wizard/Model/User/UserRegistrationPendingServiceType.hs b/wizard-server/src/Wizard/Model/User/UserRegistrationPendingServiceType.hs new file mode 100644 index 000000000..731a011a0 --- /dev/null +++ b/wizard-server/src/Wizard/Model/User/UserRegistrationPendingServiceType.hs @@ -0,0 +1,7 @@ +module Wizard.Model.User.UserRegistrationPendingServiceType where + +import GHC.Generics + +data UserRegistrationPendingServiceType + = OpenIdUserRegistrationPendingServiceType + deriving (Show, Eq, Generic, Read) diff --git a/wizard-server/src/Wizard/Model/UserEmailLink/UserEmailLinkType.hs b/wizard-server/src/Wizard/Model/UserEmailLink/UserEmailLinkType.hs new file mode 100644 index 000000000..d58610e4e --- /dev/null +++ b/wizard-server/src/Wizard/Model/UserEmailLink/UserEmailLinkType.hs @@ -0,0 +1,11 @@ +module Wizard.Model.UserEmailLink.UserEmailLinkType where + +import GHC.Generics + +data UserEmailLinkType + = RegistrationUserEmailLinkType + | ForgottenPasswordUserEmailLinkType + | TwoFactorAuthUserEmailLinkType + | ConsentsRequiredUserEmailLinkType + | EmailChangeUserEmailLinkType + deriving (Show, Eq, Generic, Read) diff --git a/wizard-server/src/Wizard/Service/ActionKey/ActionKeyService.hs b/wizard-server/src/Wizard/Service/ActionKey/ActionKeyService.hs deleted file mode 100644 index a6dc1dd97..000000000 --- a/wizard-server/src/Wizard/Service/ActionKey/ActionKeyService.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Wizard.Service.ActionKey.ActionKeyService where - -import Control.Monad.Reader (liftIO) -import Data.Time -import qualified Data.UUID as U - -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO -import Shared.ActionKey.Model.ActionKey.ActionKey -import Shared.Common.Util.Date -import Shared.Common.Util.Uuid -import Wizard.Database.DAO.Common -import Wizard.Database.Mapping.ActionKey.ActionKeyType () -import Wizard.Model.ActionKey.ActionKeyType -import Wizard.Model.Context.AppContext (AppContextM) - -createActionKey :: U.UUID -> ActionKeyType -> U.UUID -> AppContextM (ActionKey U.UUID ActionKeyType) -createActionKey userUuid actionType tenantUuid = do - hash <- liftIO generateUuid - createActionKeyWithHash userUuid actionType tenantUuid (U.toString hash) - -createActionKeyWithHash :: U.UUID -> ActionKeyType -> U.UUID -> String -> AppContextM (ActionKey U.UUID ActionKeyType) -createActionKeyWithHash userUuid actionType tenantUuid hash = - runInTransaction $ do - uuid <- liftIO generateUuid - now <- liftIO getCurrentTime - let actionKey = - ActionKey - { uuid = uuid - , identity = userUuid - , aType = actionType - , hash = hash - , tenantUuid = tenantUuid - , createdAt = now - } - insertActionKey actionKey - return actionKey - -cleanActionKeys :: AppContextM () -cleanActionKeys = do - now <- liftIO getCurrentTime - let timeDelta = realToFrac . toInteger $ nominalDayInSeconds * (-1) * 14 - let dayBefore = addUTCTime timeDelta now - deleteActionKeyOlderThen dayBefore - return () diff --git a/wizard-server/src/Wizard/Service/Config/Client/ClientConfigMapper.hs b/wizard-server/src/Wizard/Service/Config/Client/ClientConfigMapper.hs index 0792bbba2..75206e5b0 100644 --- a/wizard-server/src/Wizard/Service/Config/Client/ClientConfigMapper.hs +++ b/wizard-server/src/Wizard/Service/Config/Client/ClientConfigMapper.hs @@ -13,15 +13,16 @@ import Wizard.Model.Plugin.PluginList import Wizard.Model.Tenant.Config.TenantConfig import Wizard.Model.Tenant.Tenant import Wizard.Model.User.UserProfile +import WizardLib.Public.Model.OpenId.OpenIdClient import WizardLib.Public.Model.Tenant.Config.TenantConfig -toClientConfigDTO :: ServerConfig -> TenantConfigOrganization -> TenantConfigAuthentication -> TenantConfigPrivacyAndSupport -> TenantConfigDashboardAndLoginScreen -> TenantConfigLookAndFeel -> TenantConfigRegistry -> TenantConfigProject -> TenantConfigSubmission -> TenantConfigFeatures -> TenantConfigOwl -> Maybe UserProfile -> [String] -> [PluginList] -> M.Map U.UUID A.Value -> Tenant -> ClientConfigDTO -toClientConfigDTO serverConfig tcOrganization tcAuthentication tcPrivacyAndSupport tcDashboardAndLoginScreen tcLookAndFeel tcRegistry tcProject tcSubmission tcFeatures tcOwl mUserProfile tours plugins pluginSettings tenant = +toClientConfigDTO :: ServerConfig -> TenantConfigOrganization -> TenantConfigAuthentication -> [OpenIdClient] -> TenantConfigPrivacyAndSupport -> TenantConfigDashboardAndLoginScreen -> TenantConfigLookAndFeel -> TenantConfigRegistry -> TenantConfigProject -> TenantConfigSubmission -> TenantConfigFeatures -> TenantConfigOwl -> Maybe UserProfile -> [String] -> [PluginList] -> M.Map U.UUID A.Value -> Tenant -> ClientConfigDTO +toClientConfigDTO serverConfig tcOrganization tcAuthentication openIdClients tcPrivacyAndSupport tcDashboardAndLoginScreen tcLookAndFeel tcRegistry tcProject tcSubmission tcFeatures tcOwl mUserProfile tours plugins pluginSettings tenant = ClientConfigDTO { user = mUserProfile , tours = tours , organization = tcOrganization - , authentication = toClientAuthDTO tcAuthentication + , authentication = toClientAuthDTO tcAuthentication openIdClients , privacyAndSupport = tcPrivacyAndSupport , dashboardAndLoginScreen = tcDashboardAndLoginScreen , lookAndFeel = tcLookAndFeel @@ -63,27 +64,27 @@ toClientConfigDTO serverConfig tcOrganization tcAuthentication tcPrivacyAndSuppo else [] } -toClientAuthDTO :: TenantConfigAuthentication -> ClientConfigAuthDTO -toClientAuthDTO tcAuthentication = +toClientAuthDTO :: TenantConfigAuthentication -> [OpenIdClient] -> ClientConfigAuthDTO +toClientAuthDTO tcAuthentication openIdClients = ClientConfigAuthDTO { defaultRole = tcAuthentication.defaultRole , internal = tcAuthentication.internal - , external = toClientAuthExternalDTO tcAuthentication.external + , external = toClientAuthExternalDTO openIdClients } -toClientAuthExternalDTO :: TenantConfigAuthenticationExternal -> ClientConfigAuthExternalDTO -toClientAuthExternalDTO config = +toClientAuthExternalDTO :: [OpenIdClient] -> ClientConfigAuthExternalDTO +toClientAuthExternalDTO openIdClients = ClientConfigAuthExternalDTO - { services = toClientAuthExternalServiceDTO <$> config.services + { services = fmap toClientAuthExternalServiceDTO openIdClients } -toClientAuthExternalServiceDTO :: TenantConfigAuthenticationExternalService -> ClientConfigAuthExternalServiceDTO -toClientAuthExternalServiceDTO config = +toClientAuthExternalServiceDTO :: OpenIdClient -> ClientConfigAuthExternalServiceDTO +toClientAuthExternalServiceDTO openIdClient = ClientConfigAuthExternalServiceDTO - { aId = config.aId - , name = config.name - , url = config.url - , style = config.style + { uuid = openIdClient.uuid + , name = openIdClient.name + , url = openIdClient.url + , style = openIdClient.style } toClientConfigRegistryDTO :: ServerConfigRegistry -> TenantConfigRegistry -> ClientConfigRegistryDTO diff --git a/wizard-server/src/Wizard/Service/Config/Client/ClientConfigService.hs b/wizard-server/src/Wizard/Service/Config/Client/ClientConfigService.hs index bf440d522..e98fb40c4 100644 --- a/wizard-server/src/Wizard/Service/Config/Client/ClientConfigService.hs +++ b/wizard-server/src/Wizard/Service/Config/Client/ClientConfigService.hs @@ -29,6 +29,7 @@ import Wizard.Service.KnowledgeModel.Metamodel.MigrationService import Wizard.Service.Tenant.Config.ConfigService import Wizard.Service.Tenant.TenantHelper import Wizard.Service.User.UserMapper +import WizardLib.Public.Database.DAO.OpenId.OpenIdClientDefinitionDAO import WizardLib.Public.Database.DAO.Tenant.Config.TenantConfigFeaturesDAO import WizardLib.Public.Database.DAO.Tenant.Config.TenantConfigLookAndFeelDAO import WizardLib.Public.Database.DAO.User.UserTourDAO @@ -89,11 +90,12 @@ getClientConfig mServerUrl mClientUrl = do Nothing -> return Nothing plugins <- findPlugins tenant.uuid pluginSettings <- findTenantPluginSettingValues tenant.uuid + openIdClients <- findOpenIdClientDefinitions tours <- case mCurrentUser of Just currentUser -> findUserToursByUserUuid currentUser.uuid _ -> return [] - return $ toClientConfigDTO serverConfig tcOrganization tcAuthentication tcPrivacyAndSupport tcDashboardAndLoginScreen tcLookAndFeel tcRegistry tcProject tcSubmission tcFeatures tcOwl mUserProfile tours plugins pluginSettings tenant + return $ toClientConfigDTO serverConfig tcOrganization tcAuthentication openIdClients tcPrivacyAndSupport tcDashboardAndLoginScreen tcLookAndFeel tcRegistry tcProject tcSubmission tcFeatures tcOwl mUserProfile tours plugins pluginSettings tenant throwErrorIfTenantIsDisabled :: Maybe String -> Tenant -> AppContextM () throwErrorIfTenantIsDisabled mServerUrl tenant = unless tenant.enabled (throwError . NotExistsError $ _ERROR_VALIDATION__TENANT_OR_ACTIVE_PLAN_ABSENCE (fromMaybe "not-provided" mServerUrl)) diff --git a/wizard-server/src/Wizard/Service/Dev/DevOperationDefinitions.hs b/wizard-server/src/Wizard/Service/Dev/DevOperationDefinitions.hs index e2d404db2..4de14c8d8 100644 --- a/wizard-server/src/Wizard/Service/Dev/DevOperationDefinitions.hs +++ b/wizard-server/src/Wizard/Service/Dev/DevOperationDefinitions.hs @@ -14,7 +14,6 @@ import Wizard.Model.Cache.ServerCache hiding (user) import Wizard.Model.Context.AppContext hiding (cache) import Wizard.Model.Context.ContextMappers import Wizard.Model.Tenant.Tenant -import Wizard.Service.ActionKey.ActionKeyService import Wizard.Service.Document.DocumentCleanService import Wizard.Service.Feedback.FeedbackService import Wizard.Service.KnowledgeModel.Editor.Event.EditorEventService @@ -27,14 +26,14 @@ import Wizard.Service.Project.Event.ProjectEventService import Wizard.Service.Project.ProjectService import Wizard.Service.Registry.Push.RegistryPushService import Wizard.Service.Registry.Synchronization.RegistrySynchronizationService +import Wizard.Service.UserEmailLink.UserEmailLinkService import Wizard.Service.UserToken.ApiKey.ApiKeyService import WizardLib.Public.Service.TemporaryFile.TemporaryFileService import WizardLib.Public.Service.UserToken.UserTokenService sections :: [DevSection AppContextM] sections = - [ actionKey - , apiKey + [ apiKey , cache , document , feedback @@ -47,31 +46,9 @@ sections = , registry , temporaryFile , user + , userEmailLink ] --- --------------------------------------------------------------------------------------------------------------------- --- ACTION KEY --- --------------------------------------------------------------------------------------------------------------------- -actionKey :: DevSection AppContextM -actionKey = - DevSection - { name = "Action Key" - , description = Nothing - , operations = [actionKey_cleanActionKeys] - } - --- --------------------------------------------------------------------------------------------------------------------- -actionKey_cleanActionKeys :: DevOperation AppContextM -actionKey_cleanActionKeys = - DevOperation - { name = "Clean Expired Action Keys" - , description = Nothing - , parameters = [] - , function = \reqDto -> do - cleanActionKeys - return "Done" - } - -- --------------------------------------------------------------------------------------------------------------------- -- API KEY -- --------------------------------------------------------------------------------------------------------------------- @@ -734,3 +711,26 @@ user_cleanTokens = cleanTokens return "Done" } + +-- --------------------------------------------------------------------------------------------------------------------- +-- USER EMAIL LINK +-- --------------------------------------------------------------------------------------------------------------------- +userEmailLink :: DevSection AppContextM +userEmailLink = + DevSection + { name = "User Email Link" + , description = Nothing + , operations = [userEmailLink_cleanUserEmailLinks] + } + +-- --------------------------------------------------------------------------------------------------------------------- +userEmailLink_cleanUserEmailLinks :: DevOperation AppContextM +userEmailLink_cleanUserEmailLinks = + DevOperation + { name = "Clean Expired User Email Links" + , description = Nothing + , parameters = [] + , function = \reqDto -> do + cleanUserEmailLinks + return "Done" + } diff --git a/wizard-server/src/Wizard/Service/Mail/Mailer.hs b/wizard-server/src/Wizard/Service/Mail/Mailer.hs index 7a7ebef1c..8ced30f54 100644 --- a/wizard-server/src/Wizard/Service/Mail/Mailer.hs +++ b/wizard-server/src/Wizard/Service/Mail/Mailer.hs @@ -62,6 +62,7 @@ sendRegistrationConfirmationMail user hash clientUrl = , ("illustrationsColor", A.maybeString tcLookAndFeel.illustrationsColor) , ("supportEmail", A.maybeString tcPrivacyAndSupport.supportEmail) , ("mailConfigUuid", A.maybeUuid tcMail.configUuid) + , ("mailCustomTemplates", A.bool tcMail.customTemplates) ] } sendEmailWithTenant body user.uuid user.tenantUuid @@ -92,6 +93,39 @@ sendRegistrationCreatedAnalyticsMail user = , ("illustrationsColor", A.maybeString tcLookAndFeel.illustrationsColor) , ("supportEmail", A.maybeString tcPrivacyAndSupport.supportEmail) , ("mailConfigUuid", A.maybeUuid tcMail.configUuid) + , ("mailCustomTemplates", A.bool tcMail.customTemplates) + ] + } + sendEmailWithTenant body user.uuid user.tenantUuid + +sendEmailChangeMail :: User -> String -> String -> AppContextM () +sendEmailChangeMail user hash newEmail = + runInTransaction $ do + tcPrivacyAndSupport <- findTenantConfigPrivacyAndSupport + tcLookAndFeel <- findTenantConfigLookAndFeel + tcMail <- findTenantConfigMail + clientUrl <- getClientUrl + let body = + MC.MailCommand + { mode = "wizard" + , template = "emailChange" + , recipients = [MC.MailRecipient {uuid = Just user.uuid, email = newEmail}] + , parameters = + M.fromList + [ ("userUuid", A.uuid user.uuid) + , ("userFirstName", A.string user.firstName) + , ("userLastName", A.string user.lastName) + , ("userEmail", A.string user.email) + , ("newEmail", A.string newEmail) + , ("hash", A.string hash) + , ("clientUrl", A.string clientUrl) + , ("appTitle", A.maybeString tcLookAndFeel.appTitle) + , ("logoUrl", A.maybeString tcLookAndFeel.logoUrl) + , ("primaryColor", A.maybeString tcLookAndFeel.primaryColor) + , ("illustrationsColor", A.maybeString tcLookAndFeel.illustrationsColor) + , ("supportEmail", A.maybeString tcPrivacyAndSupport.supportEmail) + , ("mailConfigUuid", A.maybeUuid tcMail.configUuid) + , ("mailCustomTemplates", A.bool tcMail.customTemplates) ] } sendEmailWithTenant body user.uuid user.tenantUuid @@ -122,6 +156,7 @@ sendResetPasswordMail user hash = , ("illustrationsColor", A.maybeString tcLookAndFeel.illustrationsColor) , ("supportEmail", A.maybeString tcPrivacyAndSupport.supportEmail) , ("mailConfigUuid", A.maybeUuid tcMail.configUuid) + , ("mailCustomTemplates", A.bool tcMail.customTemplates) ] } sendEmail body user.uuid @@ -152,6 +187,7 @@ sendTwoFactorAuthMail user code = , ("illustrationsColor", A.maybeString tcLookAndFeel.illustrationsColor) , ("supportEmail", A.maybeString tcPrivacyAndSupport.supportEmail) , ("mailConfigUuid", A.maybeUuid tcMail.configUuid) + , ("mailCustomTemplates", A.bool tcMail.customTemplates) ] } sendEmail body user.uuid @@ -189,6 +225,7 @@ sendProjectInvitationMail oldProject newProject = , ("illustrationsColor", A.maybeString tcLookAndFeel.illustrationsColor) , ("supportEmail", A.maybeString tcPrivacyAndSupport.supportEmail) , ("mailConfigUuid", A.maybeUuid tcMail.configUuid) + , ("mailCustomTemplates", A.bool tcMail.customTemplates) , ("inviteeUuid", A.uuid user.uuid) , ("inviteeFirstName", A.string user.firstName) , ("inviteeLastName", A.string user.lastName) @@ -206,6 +243,7 @@ sendProjectInvitationMail oldProject newProject = sendProjectCommentThreadAssignedMail :: [ProjectCommentThreadNotification] -> AppContextM () sendProjectCommentThreadAssignedMail notifications = runInTransaction $ do + tcMail <- findTenantConfigMail case notifications of [] -> return () notification : _ -> do @@ -215,6 +253,7 @@ sendProjectCommentThreadAssignedMail notifications = , ("projectName", A.string n.projectName) , ("commentThreadUuid", A.uuid n.commentThreadUuid) , ("path", A.string n.path) + , ("questionTitle", A.maybeString n.questionTitle) , ("resolved", A.bool n.resolved) , ("private", A.bool n.private) , ("assignedBy", A.toJSON n.assignedBy) @@ -236,6 +275,7 @@ sendProjectCommentThreadAssignedMail notifications = , ("illustrationsColor", A.maybeString notification.illustrationsColor) , ("supportEmail", A.maybeString notification.supportEmail) , ("mailConfigUuid", A.maybeUuid notification.mailConfigUuid) + , ("mailCustomTemplates", A.bool tcMail.customTemplates) ] } sendEmailWithTenant body notification.assignedTo.uuid notification.tenantUuid @@ -267,6 +307,7 @@ sendApiKeyCreatedMail user userToken = , ("illustrationsColor", A.maybeString tcLookAndFeel.illustrationsColor) , ("supportEmail", A.maybeString tcPrivacyAndSupport.supportEmail) , ("mailConfigUuid", A.maybeUuid tcMail.configUuid) + , ("mailCustomTemplates", A.bool tcMail.customTemplates) ] } sendEmail body user.uuid @@ -298,6 +339,7 @@ sendApiKeyExpirationMail user userToken = , ("illustrationsColor", A.maybeString tcLookAndFeel.illustrationsColor) , ("supportEmail", A.maybeString tcPrivacyAndSupport.supportEmail) , ("mailConfigUuid", A.maybeUuid tcMail.configUuid) + , ("mailCustomTemplates", A.bool tcMail.customTemplates) ] } sendEmailWithTenant body user.uuid user.tenantUuid diff --git a/wizard-server/src/Wizard/Service/OpenId/Client/Definition/OpenIdClientDefinitionService.hs b/wizard-server/src/Wizard/Service/OpenId/Client/Definition/OpenIdClientDefinitionService.hs new file mode 100644 index 000000000..fc5e9df22 --- /dev/null +++ b/wizard-server/src/Wizard/Service/OpenId/Client/Definition/OpenIdClientDefinitionService.hs @@ -0,0 +1,57 @@ +module Wizard.Service.OpenId.Client.Definition.OpenIdClientDefinitionService where + +import Control.Monad (void) +import Control.Monad.Reader (asks, liftIO) +import Data.Time +import qualified Data.UUID as U + +import Shared.Common.Constant.Acl +import Shared.Common.Util.Uuid +import Wizard.Database.DAO.Common +import Wizard.Model.Context.AclContext +import Wizard.Model.Context.AppContext +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeDTO +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailDTO +import WizardLib.Public.Database.DAO.OpenId.OpenIdClientDefinitionDAO +import WizardLib.Public.Model.OpenId.OpenIdClientSimple +import WizardLib.Public.Service.OpenId.Client.Definition.OpenIdClientDefinitionMapper + +getOpenIdClientDefinitions :: AppContextM [OpenIdClientSimple] +getOpenIdClientDefinitions = do + checkPermission _CFG_PERM + openIdClients <- findOpenIdClientDefinitions + return . fmap toSimple $ openIdClients + +getOpenIdClientDefinitionByUuid :: U.UUID -> AppContextM OpenIdClientDetailDTO +getOpenIdClientDefinitionByUuid uuid = do + checkPermission _CFG_PERM + openIdClient <- findOpenIdClientDefinitionByUuid uuid + return $ toDetailDTO openIdClient + +createOpenIdClientDefinition :: OpenIdClientChangeDTO -> AppContextM OpenIdClientDetailDTO +createOpenIdClientDefinition reqDto = + runInTransaction $ do + checkPermission _CFG_PERM + uuid <- liftIO generateUuid + tenantUuid <- asks currentTenantUuid + now <- liftIO getCurrentTime + let openIdClient = fromCreateDTO reqDto uuid tenantUuid now + void $ insertOpenIdClientDefinition openIdClient + return $ toDetailDTO openIdClient + +modifyOpenIdClientDefinition :: U.UUID -> OpenIdClientChangeDTO -> AppContextM OpenIdClientDetailDTO +modifyOpenIdClientDefinition uuid reqDto = + runInTransaction $ do + checkPermission _CFG_PERM + openIdClient <- findOpenIdClientDefinitionByUuid uuid + now <- liftIO getCurrentTime + let updatedOpenIdClient = fromChangeDTO openIdClient reqDto now + void $ updateOpenIdClientDefinition updatedOpenIdClient + return $ toDetailDTO updatedOpenIdClient + +deleteOpenIdClientDefinition :: U.UUID -> AppContextM () +deleteOpenIdClientDefinition uuid = + runInTransaction $ do + checkPermission _CFG_PERM + _ <- findOpenIdClientDefinitionByUuid uuid + deleteOpenIdClientDefinitionByUuid uuid diff --git a/wizard-server/src/Wizard/Service/OpenId/Client/Flow/OpenIdClientFlowService.hs b/wizard-server/src/Wizard/Service/OpenId/Client/Flow/OpenIdClientFlowService.hs index ffab8fbf9..7838450a4 100644 --- a/wizard-server/src/Wizard/Service/OpenId/Client/Flow/OpenIdClientFlowService.hs +++ b/wizard-server/src/Wizard/Service/OpenId/Client/Flow/OpenIdClientFlowService.hs @@ -1,76 +1,212 @@ module Wizard.Service.OpenId.Client.Flow.OpenIdClientFlowService where +import Control.Monad (unless) import Control.Monad.Except (throwError) import Control.Monad.Reader (asks, liftIO) import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.List as L import Data.Maybe (fromJust, fromMaybe) import qualified Data.Text as T +import Data.Time +import qualified Data.UUID as U import qualified Web.OIDC.Client as O +import qualified Web.OIDC.Client.IdTokenFlow as O_ID +import qualified Web.OIDC.Client.Tokens as OT -import Shared.ActionKey.Model.ActionKey.ActionKey import Shared.Common.Model.Error.Error +import Shared.Common.Util.Crypto (generateRandomString) +import Shared.Common.Util.Uuid +import Shared.OpenId.Model.OpenId.OpenIdClientParameter import Shared.OpenId.Service.OpenId.Client.Flow.OpenIdClientFlowService -import Shared.OpenId.Service.OpenId.Client.Flow.OpenIdClientFlowUtil +import Shared.OpenId.Service.OpenId.Client.Flow.OpenIdClientFlowUtil (parseIdToken) import Wizard.Database.DAO.Common import Wizard.Database.DAO.User.UserDAO +import Wizard.Database.Mapping.User.UserRegistrationPendingServiceType () import Wizard.Localization.Messages.Public -import Wizard.Model.ActionKey.ActionKeyType import Wizard.Model.Context.AppContext -import Wizard.Model.Tenant.Config.TenantConfig +import Wizard.Model.Context.AppContextHelpers import Wizard.Model.User.User -import Wizard.Service.ActionKey.ActionKeyService +import Wizard.Model.User.UserRegistrationPendingServiceType import Wizard.Service.Tenant.Config.ConfigService import Wizard.Service.Tenant.TenantHelper import Wizard.Service.User.UserService import Wizard.Service.User.UserUtil import Wizard.Service.UserToken.Login.LoginService +import Wizard.Service.UserToken.Login.LoginValidation import WizardLib.Public.Api.Resource.UserToken.UserTokenDTO +import WizardLib.Public.Database.DAO.OpenId.OpenIdClientDefinitionDAO +import WizardLib.Public.Database.DAO.User.UserOpenIdIdentityDAO +import WizardLib.Public.Localization.Messages.Public +import WizardLib.Public.Model.OpenId.OpenIdClient +import WizardLib.Public.Model.User.UserOpenIdIdentity +import WizardLib.Public.Model.User.UserRegistrationPending +import WizardLib.Public.Service.User.UserRegistrationPendingService (upsertPendingExternalRegistration) -createAuthenticationUrl :: String -> Maybe String -> Maybe String -> AppContextM () -createAuthenticationUrl authId mFlow mClientUrl = do - (service, openIDClient) <- createOpenIDClient authId mClientUrl - createAuthenticationUrl' openIDClient service.parameters mFlow mClientUrl +createAuthenticationUrl :: U.UUID -> Maybe String -> Maybe String -> AppContextM () +createAuthenticationUrl providerUuid mFlow mClientUrl = do + (openIdClient, oidc) <- buildOidcClient providerUuid mClientUrl + let scopes = buildScopes openIdClient + state <- liftIO $ generateRandomString 40 + let nonce = "FtEIbRdfFc7z2bNjCTaZKDcWNeUKUelvs13K21VL" + let params = + fmap (\p -> (BS.pack p.name, Just . BS.pack $ p.value)) openIdClient.parameters + ++ [("nonce", Just . BS.pack $ nonce)] + loc <- + case mFlow of + Just "id_token" -> liftIO $ O_ID.getAuthenticationRequestUrl oidc scopes (Just . BS.pack $ state) params + _ -> liftIO $ O.getAuthenticationRequestUrl oidc scopes (Just . BS.pack $ state) params + throwError $ FoundError (show loc) -loginUser :: String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> AppContextM UserTokenDTO -loginUser authId mClientUrl mError mCode mNonce mIdToken mUserAgent mSessionState = +loginUserOrLinkIdentity + :: Bool + -> U.UUID + -> Maybe String + -> Maybe String + -> Maybe String + -> Maybe String + -> Maybe String + -> Maybe String + -> Maybe String + -> AppContextM UserTokenDTO +loginUserOrLinkIdentity isAuthenticated providerUuid mClientUrl mError mCode mNonce mIdToken mUserAgent mSessionState = + if isAuthenticated + then do + mCurrentUserUuid <- getCurrentUserUuid + case mCurrentUserUuid of + Just currentUserUuid -> do + linkOpenIdIdentity currentUserUuid providerUuid mClientUrl mError mCode mNonce mIdToken + return IdentityLinkedDTO + Nothing -> loginUser providerUuid mClientUrl mError mCode mNonce mIdToken mUserAgent mSessionState + else loginUser providerUuid mClientUrl mError mCode mNonce mIdToken mUserAgent mSessionState + +loginUser + :: U.UUID + -> Maybe String + -> Maybe String + -> Maybe String + -> Maybe String + -> Maybe String + -> Maybe String + -> Maybe String + -> AppContextM UserTokenDTO +loginUser providerUuid mClientUrl _mError mCode mNonce mIdToken mUserAgent mSessionState = + runInTransaction $ do + (openIdClient, oidc) <- buildOidcClient providerUuid mClientUrl + (externalId, mEmail, mFirstName, mLastName, mPicture, mUserUuid) <- resolveExternalIdentity oidc mCode mNonce mIdToken + tcAuthentication <- getCurrentTenantConfigAuthentication + mIdentity <- findUserOpenIdIdentityByExternalIdAndProvider' externalId providerUuid + case mIdentity of + Just identity -> do + user <- findUserByUuid identity.userUuid + validateLoginEnabled tcAuthentication user + createLoginToken user mUserAgent mSessionState + Nothing -> do + mUserByEmail <- case mEmail of + Just email -> findUserByEmail' email + Nothing -> return Nothing + case mUserByEmail of + Just userByEmail -> do + validateLoginEnabled tcAuthentication userByEmail + insertOpenIdIdentityLink userByEmail.uuid openIdClient externalId + createLoginToken userByEmail mUserAgent mSessionState + Nothing -> do + unless openIdClient.registrationEnabled $ + throwError $ + UserError _ERROR_SERVICE_OPENID__REGISTRATION_DISABLED + case (mEmail, mFirstName, mLastName) of + (Just email, Just firstName, Just lastName) -> do + consentRequired <- isConsentRequired Nothing + user <- createUserFromOpenIdLogin openIdClient externalId firstName lastName email mPicture mUserUuid (not consentRequired) + validateLoginEnabled tcAuthentication user + createLoginToken user mUserAgent mSessionState + _ -> do + pending <- upsertPendingExternalRegistration OpenIdUserRegistrationPendingServiceType providerUuid externalId Nothing mEmail mFirstName mLastName mPicture Nothing + return $ + CompleteRegistrationRequiredDTO + { hash = pending.hash + , email = pending.email + , firstName = pending.firstName + , lastName = pending.lastName + , imageUrl = pending.imageUrl + } + +linkOpenIdIdentity + :: U.UUID + -> U.UUID + -> Maybe String + -> Maybe String + -> Maybe String + -> Maybe String + -> Maybe String + -> AppContextM () +linkOpenIdIdentity currentUserUuid providerUuid mClientUrl _mError mCode mNonce mIdToken = runInTransaction $ do - httpClientManager <- asks httpClientManager - (_, openIDClient) <- createOpenIDClient authId mClientUrl - idToken <- - case mIdToken of - Just idToken -> return . fromJust . A.decode . BSL.pack $ idToken - Nothing -> do - tokens <- requestTokensWithCode openIDClient mCode mNonce - return . O.idToken $ tokens - (email, firstName, lastName, mPicture, mUserUuid) <- parseIdToken idToken - mUserFromDb <- findUserByEmail' email - consentRequired <- isConsentRequired mUserFromDb - user <- createUserFromExternalService mUserFromDb authId firstName lastName email mPicture mUserUuid (not consentRequired) - case (mUserFromDb, consentRequired) of - (Nothing, True) -> do - actionKey <- createActionKey user.uuid ConsentsRequiredActionKey user.tenantUuid - return $ ConsentsRequiredDTO {hash = actionKey.hash} - _ -> createLoginToken user mUserAgent mSessionState + (openIdClient, oidc) <- buildOidcClient providerUuid mClientUrl + (externalId, _mEmail, _mFirstName, _mLastName, _mPicture, _mUserUuid) <- resolveExternalIdentity oidc mCode mNonce mIdToken + mIdentity <- findUserOpenIdIdentityByExternalIdAndProvider' externalId providerUuid + case mIdentity of + Just identity -> + unless (identity.userUuid == currentUserUuid) $ + throwError $ + UserError _ERROR_SERVICE_OPENID__IDENTITY_LINKED_TO_DIFFERENT_USER + Nothing -> insertOpenIdIdentityLink currentUserUuid openIdClient externalId -- -------------------------------- -- PRIVATE -- -------------------------------- -createOpenIDClient :: String -> Maybe String -> AppContextM (TenantConfigAuthenticationExternalService, O.OIDC) -createOpenIDClient authId mClientUrl = do +buildOidcClient :: U.UUID -> Maybe String -> AppContextM (OpenIdClient, O.OIDC) +buildOidcClient providerUuid mClientUrl = do httpClientManager <- asks httpClientManager - serverConfig <- asks serverConfig - tcAuthentication <- getCurrentTenantConfigAuthentication clientUrl <- getClientUrl - case L.find (\s -> s.aId == authId) tcAuthentication.external.services of - Just service -> do - prov <- liftIO $ O.discover (T.pack service.url) httpClientManager - let cId = BS.pack service.clientId - let cSecret = BS.pack service.clientSecret + mOpenIdClient <- findOpenIdClientDefinitionByUuid' providerUuid + case mOpenIdClient of + Just openIdClient -> do + prov <- liftIO $ O.discover (T.pack openIdClient.url) httpClientManager + let cId = BS.pack openIdClient.clientId + let cSecret = BS.pack openIdClient.clientSecret let clientCallbackUrl = fromMaybe clientUrl mClientUrl - let redirectUrl = BS.pack $ clientCallbackUrl ++ "/auth/" ++ authId ++ "/callback" - let openIDClient = O.setCredentials cId cSecret redirectUrl (O.newOIDC prov) - return (service, openIDClient) - Nothing -> throwError . UserError $ _ERROR_SERVICE_AUTH__SERVICE_NOT_DEFINED authId + let redirectUrl = BS.pack $ clientCallbackUrl ++ "/open-id/" ++ U.toString providerUuid ++ "/callback" + let oidc = O.setCredentials cId cSecret redirectUrl (O.newOIDC prov) + return (openIdClient, oidc) + Nothing -> throwError . UserError $ _ERROR_SERVICE_AUTH__SERVICE_NOT_DEFINED (U.toString providerUuid) + +buildScopes :: OpenIdClient -> [O.ScopeValue] +buildScopes openIdClient = + [O.openId] + ++ [O.email | openIdClient.scopeEmail] + ++ [O.profile | openIdClient.scopeProfile] + +resolveExternalIdentity + :: O.OIDC + -> Maybe String + -> Maybe String + -> Maybe String + -> AppContextM (String, Maybe String, Maybe String, Maybe String, Maybe String, Maybe U.UUID) +resolveExternalIdentity oidc mCode mNonce mIdToken = do + idToken <- + case mIdToken of + Just idToken -> return . fromJust . A.decode . BSL.pack $ idToken + Nothing -> do + tokens <- requestTokensWithCode oidc mCode mNonce + return . O.idToken $ tokens + let externalId = T.unpack . OT.sub $ idToken + (mEmail, mFirstName, mLastName, mPicture, mUserUuid) <- parseIdToken idToken + return (externalId, mEmail, mFirstName, mLastName, mPicture, mUserUuid) + +insertOpenIdIdentityLink :: U.UUID -> OpenIdClient -> String -> AppContextM () +insertOpenIdIdentityLink userUuid openIdClient externalId = do + identityUuid <- liftIO generateUuid + now <- liftIO getCurrentTime + let identity = + UserOpenIdIdentity + { uuid = identityUuid + , externalId = externalId + , externalLabel = Nothing + , userUuid = userUuid + , providerUuid = openIdClient.uuid + , tenantUuid = openIdClient.tenantUuid + , createdAt = now + } + _ <- insertUserOpenIdIdentity identity + return () diff --git a/wizard-server/src/Wizard/Service/PersistentCommand/PersistentCommandService.hs b/wizard-server/src/Wizard/Service/PersistentCommand/PersistentCommandService.hs index cd128f4d4..c5407100b 100644 --- a/wizard-server/src/Wizard/Service/PersistentCommand/PersistentCommandService.hs +++ b/wizard-server/src/Wizard/Service/PersistentCommand/PersistentCommandService.hs @@ -18,7 +18,7 @@ import Wizard.Database.DAO.Common import Wizard.Database.DAO.PersistentCommand.PersistentCommandDAO import Wizard.Database.DAO.Tenant.TenantDAO import Wizard.Database.DAO.User.UserDAO -import Wizard.Database.Mapping.ActionKey.ActionKeyType () +import Wizard.Database.Mapping.UserEmailLink.UserEmailLinkType () import Wizard.Model.Context.AclContext import Wizard.Model.Context.AppContext import Wizard.Model.Context.ContextMappers diff --git a/wizard-server/src/Wizard/Service/Project/Comment/ProjectCommentService.hs b/wizard-server/src/Wizard/Service/Project/Comment/ProjectCommentService.hs index 2f6e99dec..8d6e1d142 100644 --- a/wizard-server/src/Wizard/Service/Project/Comment/ProjectCommentService.hs +++ b/wizard-server/src/Wizard/Service/Project/Comment/ProjectCommentService.hs @@ -1,9 +1,10 @@ module Wizard.Service.Project.Comment.ProjectCommentService where import Control.Monad.Except (catchError) -import Control.Monad.Reader (liftIO) +import Control.Monad.Reader (liftIO, local) import Data.Foldable (traverse_) import qualified Data.Map.Strict as M +import qualified Data.Maybe as Maybe import qualified Data.UUID as U import Shared.Common.Model.Common.Page @@ -11,7 +12,10 @@ import Shared.Common.Model.Common.Pageable import Shared.Common.Model.Common.Sort import Shared.Common.Service.Acl.AclService import Shared.Common.Util.List +import Shared.Common.Util.String (splitOn) import Shared.Common.Util.Uuid +import Shared.KnowledgeModel.Model.KnowledgeModel.KnowledgeModel +import Shared.KnowledgeModel.Model.KnowledgeModel.KnowledgeModelLenses import Wizard.Constant.Acl import Wizard.Database.DAO.Common import Wizard.Database.DAO.Project.ProjectCommentDAO @@ -23,6 +27,7 @@ import Wizard.Model.Project.Comment.ProjectCommentList import Wizard.Model.Project.Comment.ProjectCommentThreadAssigned import Wizard.Model.Project.Comment.ProjectCommentThreadNotification import Wizard.Model.Project.Project +import Wizard.Service.KnowledgeModel.KnowledgeModelService import Wizard.Service.Mail.Mailer import Wizard.Service.Project.Comment.ProjectCommentMapper import Wizard.Service.Project.ProjectAcl @@ -73,5 +78,32 @@ sendNotificationToNewAssignees = runInTransaction $ do threads <- findProjectCommentThreadsForNotifying let threadGroups = groupBy (\t1 t2 -> t1.assignedTo.uuid == t2.assignedTo.uuid && t1.tenantUuid == t2.tenantUuid) threads - traverse_ sendProjectCommentThreadAssignedMail threadGroups + traverse_ sendNotificationGroup threadGroups unsetProjectCommentThreadNotificationRequired + +sendNotificationGroup :: [ProjectCommentThreadNotification] -> AppContextM () +sendNotificationGroup [] = return () +sendNotificationGroup notifications@(notification : _) = do + enriched <- + local (\c -> c {currentTenantUuid = notification.tenantUuid}) $ + traverse fillInQuestionTitle notifications + sendProjectCommentThreadAssignedMail enriched + +fillInQuestionTitle :: ProjectCommentThreadNotification -> AppContextM ProjectCommentThreadNotification +fillInQuestionTitle n = do + title <- + catchError + ( do + km <- compileKnowledgeModel [] (Just n.knowledgeModelPackageUuid) n.selectedQuestionTagUuids + return $ resolveQuestionTitleFromPath km n.path + ) + (\_ -> return Nothing) + return $ n {questionTitle = title} + +resolveQuestionTitleFromPath :: KnowledgeModel -> String -> Maybe String +resolveQuestionTitleFromPath km path = + let segments = Maybe.mapMaybe U.fromString (splitOn "." path) + questions = Maybe.mapMaybe (`M.lookup` getQuestionsM km) segments + in case reverse questions of + q : _ -> Just (getTitle q) + [] -> Nothing diff --git a/wizard-server/src/Wizard/Service/Submission/SubmissionMapper.hs b/wizard-server/src/Wizard/Service/Submission/SubmissionMapper.hs index c583eaac5..df29d1d32 100644 --- a/wizard-server/src/Wizard/Service/Submission/SubmissionMapper.hs +++ b/wizard-server/src/Wizard/Service/Submission/SubmissionMapper.hs @@ -8,13 +8,13 @@ import Wizard.Model.Submission.SubmissionList import Wizard.Model.Tenant.Config.TenantConfig import WizardLib.Public.Model.User.UserSuggestion -toList :: Submission -> TenantConfigSubmissionService -> UserSuggestion -> SubmissionList +toList :: Submission -> TenantConfigSubmissionService -> Maybe UserSuggestion -> SubmissionList toList Submission {..} service createdBy2 = let serviceName = Just service.name createdBy = createdBy2 in SubmissionList {..} -fromCreate :: U.UUID -> String -> U.UUID -> U.UUID -> U.UUID -> UTCTime -> Submission +fromCreate :: U.UUID -> String -> U.UUID -> U.UUID -> Maybe U.UUID -> UTCTime -> Submission fromCreate uuid serviceId documentUuid tenantUuid createdBy now = Submission { uuid = uuid diff --git a/wizard-server/src/Wizard/Service/Submission/SubmissionService.hs b/wizard-server/src/Wizard/Service/Submission/SubmissionService.hs index 9694663a3..63a78bfec 100644 --- a/wizard-server/src/Wizard/Service/Submission/SubmissionService.hs +++ b/wizard-server/src/Wizard/Service/Submission/SubmissionService.hs @@ -71,7 +71,7 @@ submitDocument docUuid reqDto = :: Submission savedSubmission <- updateSubmissionByUuid updatedSub currentUser <- getCurrentUser - return $ toList savedSubmission tcSubmission (toSuggestion' currentUser) + return $ toList savedSubmission tcSubmission (Just $ toSuggestion' currentUser) where getUserProps tcSubmission = do mUser <- asks currentUser @@ -96,6 +96,6 @@ createSubmission docUuid reqDto = do now <- liftIO getCurrentTime tenantUuid <- asks currentTenantUuid currentUser <- getCurrentUser - let sub = fromCreate sUuid reqDto.serviceId docUuid tenantUuid currentUser.uuid now + let sub = fromCreate sUuid reqDto.serviceId docUuid tenantUuid (Just currentUser.uuid) now insertSubmission sub return sub diff --git a/wizard-server/src/Wizard/Service/Tenant/Config/ConfigMapper.hs b/wizard-server/src/Wizard/Service/Tenant/Config/ConfigMapper.hs index e81c4955d..2cf42dcef 100644 --- a/wizard-server/src/Wizard/Service/Tenant/Config/ConfigMapper.hs +++ b/wizard-server/src/Wizard/Service/Tenant/Config/ConfigMapper.hs @@ -3,7 +3,6 @@ module Wizard.Service.Tenant.Config.ConfigMapper where import Data.Time import qualified Data.UUID as U -import Shared.OpenId.Model.OpenId.OpenIdClientStyle import Wizard.Api.Resource.Tenant.Config.TenantConfigChangeDTO import Wizard.Model.Tenant.Config.TenantConfig import Wizard.Model.Tenant.Config.TenantConfigSubmissionServiceSimple @@ -63,13 +62,7 @@ fromOrganizationChangeDTO :: TenantConfigOrganizationChangeDTO -> U.UUID -> UTCT fromOrganizationChangeDTO TenantConfigOrganizationChangeDTO {..} tenantUuid createdAt updatedAt = TenantConfigOrganization {..} fromAuthenticationChangeDTO :: TenantConfigAuthenticationChangeDTO -> U.UUID -> UTCTime -> UTCTime -> TenantConfigAuthentication -fromAuthenticationChangeDTO a@TenantConfigAuthenticationChangeDTO {..} tenantUuid createdAt updatedAt = - let services = fmap (\c -> fromAuthenticationExternalServiceChangeDTO c tenantUuid createdAt updatedAt) a.external.services - external = TenantConfigAuthenticationExternal {..} - in TenantConfigAuthentication {..} - -fromAuthenticationExternalServiceChangeDTO :: TenantConfigAuthenticationExternalServiceChangeDTO -> U.UUID -> UTCTime -> UTCTime -> TenantConfigAuthenticationExternalService -fromAuthenticationExternalServiceChangeDTO TenantConfigAuthenticationExternalServiceChangeDTO {..} tenantUuid createdAt updatedAt = TenantConfigAuthenticationExternalService {..} +fromAuthenticationChangeDTO TenantConfigAuthenticationChangeDTO {..} tenantUuid createdAt updatedAt = TenantConfigAuthentication {..} fromPrivacyAndSupportChangeDTO :: TenantConfigPrivacyAndSupportChangeDTO -> U.UUID -> UTCTime -> UTCTime -> TenantConfigPrivacyAndSupport fromPrivacyAndSupportChangeDTO TenantConfigPrivacyAndSupportChangeDTO {..} tenantUuid createdAt updatedAt = TenantConfigPrivacyAndSupport {..} @@ -115,32 +108,8 @@ fromFeaturesChangeDTO dto oldConfig tenantUuid createdAt updatedAt = in TenantConfigFeatures {..} fromAuthenticationCommand :: TenantConfigAuthentication -> CreateOrUpdateAuthenticationConfigCommand -> UTCTime -> TenantConfigAuthentication -fromAuthenticationCommand oldConfig command now = - oldConfig - { external = - oldConfig.external - { services = - [ TenantConfigAuthenticationExternalService - { aId = command.aId - , name = command.name - , url = command.url - , clientId = U.toString command.clientId - , clientSecret = command.clientSecret - , parameters = [] - , style = - OpenIdClientStyle - { icon = Nothing - , background = Nothing - , color = Nothing - } - , tenantUuid = command.tenantUuid - , createdAt = now - , updatedAt = now - } - ] - } - , updatedAt = now - } +fromAuthenticationCommand oldConfig _command now = + oldConfig {updatedAt = now} fromRegistry :: TenantConfigRegistry -> UpdateRegistryConfigCommand -> UTCTime -> TenantConfigRegistry fromRegistry oldConfig command now = diff --git a/wizard-server/src/Wizard/Service/Tenant/Config/ConfigValidation.hs b/wizard-server/src/Wizard/Service/Tenant/Config/ConfigValidation.hs index 7094e14d0..3c1270335 100644 --- a/wizard-server/src/Wizard/Service/Tenant/Config/ConfigValidation.hs +++ b/wizard-server/src/Wizard/Service/Tenant/Config/ConfigValidation.hs @@ -1,12 +1,11 @@ module Wizard.Service.Tenant.Config.ConfigValidation where import Control.Monad.Except (throwError) -import Data.Foldable (forM_, traverse_) +import Data.Foldable (forM_) import qualified Data.Map.Strict as M import Data.Maybe (isJust) import Text.Regex (matchRegex, mkRegex) -import Shared.Common.Localization.Messages.Public import Shared.Common.Model.Error.Error import Shared.Coordinate.Localization.Messages.Public import Wizard.Api.Resource.Tenant.Config.TenantConfigChangeDTO @@ -17,7 +16,6 @@ import Wizard.Service.Project.ProjectValidation validateTenantConfig :: TenantConfigChangeDTO -> AppContextM () validateTenantConfig reqDto = do validateOrganization reqDto.organization - validateAuthentication reqDto.authentication validateProject reqDto.project validateOrganization :: TenantConfigOrganizationChangeDTO -> AppContextM () @@ -31,15 +29,5 @@ isValidOrganizationId kmId = where validationRegex = mkRegex "^[a-zA-Z0-9_.-]+$" -validateAuthentication :: TenantConfigAuthenticationChangeDTO -> AppContextM () -validateAuthentication config = - let validate service = - if isJust $ matchRegex validationRegex service.aId - then return () - else throwError $ ValidationError [] (M.singleton "id" [_ERROR_VALIDATION__FORBIDDEN_CHARACTERS service.aId]) - where - validationRegex = mkRegex "^[a-z0-9-]+$" - in traverse_ validate config.external.services - validateProject :: TenantConfigProjectChangeDTO -> AppContextM () validateProject config = validateProjectTags config.projectTagging.tags diff --git a/wizard-server/src/Wizard/Service/User/ExternalIdentity/UserExternalIdentityService.hs b/wizard-server/src/Wizard/Service/User/ExternalIdentity/UserExternalIdentityService.hs new file mode 100644 index 000000000..19e6ee72b --- /dev/null +++ b/wizard-server/src/Wizard/Service/User/ExternalIdentity/UserExternalIdentityService.hs @@ -0,0 +1,32 @@ +module Wizard.Service.User.ExternalIdentity.UserExternalIdentityService where + +import Control.Monad (unless) +import Control.Monad.Except (throwError) +import qualified Data.UUID as U + +import Shared.Common.Localization.Messages.Public +import Shared.Common.Model.Error.Error +import Wizard.Api.Resource.User.UserDTO +import Wizard.Database.DAO.Common +import Wizard.Model.Context.AppContext +import Wizard.Model.Context.AppContextHelpers +import WizardLib.Public.Api.Resource.User.UserOpenIdIdentityDTO +import WizardLib.Public.Database.DAO.User.UserOpenIdIdentityDAO +import WizardLib.Public.Model.User.UserOpenIdIdentity +import WizardLib.Public.Service.User.UserOpenIdIdentityMapper + +getUserIdentities :: AppContextM [UserOpenIdIdentityDTO] +getUserIdentities = do + currentUser <- getCurrentUser + identities <- findUserOpenIdIdentityListsByUserUuid (currentUser :: UserDTO).uuid + return . fmap toDTO $ identities + +deleteUserIdentity :: U.UUID -> AppContextM () +deleteUserIdentity uuid = + runInTransaction $ do + currentUser <- getCurrentUser + identities <- findUserOpenIdIdentitiesByUserUuid (currentUser :: UserDTO).uuid + unless (any (\i -> (i :: UserOpenIdIdentity).uuid == uuid) identities) $ + throwError $ + NotExistsError (_ERROR_DATABASE__ENTITY_NOT_FOUND "user_openid_identity" [("uuid", U.toString uuid)]) + deleteUserOpenIdIdentityByUuid uuid diff --git a/wizard-server/src/Wizard/Service/User/Profile/UserProfileMapper.hs b/wizard-server/src/Wizard/Service/User/Profile/UserProfileMapper.hs index 41cfb9a67..78bbff80d 100644 --- a/wizard-server/src/Wizard/Service/User/Profile/UserProfileMapper.hs +++ b/wizard-server/src/Wizard/Service/User/Profile/UserProfileMapper.hs @@ -10,28 +10,39 @@ import Wizard.Model.User.User import Wizard.Model.User.UserSubmissionProp import Wizard.Model.User.UserSubmissionPropList -fromUserProfileChangeDTO :: User -> UserProfileChangeDTO -> UTCTime -> User -fromUserProfileChangeDTO oldUser dto now = - User - { uuid = oldUser.uuid - , firstName = dto.firstName - , lastName = dto.lastName - , email = toLower <$> dto.email - , passwordHash = oldUser.passwordHash - , affiliation = dto.affiliation - , sources = oldUser.sources - , uRole = oldUser.uRole - , permissions = oldUser.permissions - , active = oldUser.active - , imageUrl = oldUser.imageUrl - , locale = oldUser.locale - , machine = oldUser.machine - , lastSeenNewsId = oldUser.lastSeenNewsId - , tenantUuid = oldUser.tenantUuid - , lastVisitedAt = oldUser.lastVisitedAt - , createdAt = oldUser.createdAt - , updatedAt = now - } +fromUserProfileChangeDTO :: UserProfileChangeDTO -> User -> Bool -> UTCTime -> User +fromUserProfileChangeDTO dto oldUser revertPending now = + let newEmail = toLower <$> dto.email + emailChanged = newEmail /= oldUser.email + newEmailVerifiedAt + | emailChanged = Nothing + | revertPending = Just now + | otherwise = oldUser.emailVerifiedAt + newEmailPending + | emailChanged = Just newEmail + | revertPending = Nothing + | otherwise = oldUser.emailPending + in User + { uuid = oldUser.uuid + , firstName = dto.firstName + , lastName = dto.lastName + , email = oldUser.email + , passwordHash = oldUser.passwordHash + , affiliation = dto.affiliation + , uRole = oldUser.uRole + , permissions = oldUser.permissions + , active = oldUser.active + , imageUrl = oldUser.imageUrl + , locale = oldUser.locale + , machine = oldUser.machine + , lastSeenNewsId = oldUser.lastSeenNewsId + , tenantUuid = oldUser.tenantUuid + , lastVisitedAt = oldUser.lastVisitedAt + , createdAt = oldUser.createdAt + , updatedAt = now + , emailVerifiedAt = newEmailVerifiedAt + , emailPending = newEmailPending + } fromUserSubmissionPropsDTO :: U.UUID -> U.UUID -> [UserSubmissionProp] -> [UserSubmissionPropList] -> UTCTime -> [UserSubmissionProp] fromUserSubmissionPropsDTO userUuid tenantUuid submissionProps reqDtos now = diff --git a/wizard-server/src/Wizard/Service/User/Profile/UserProfileService.hs b/wizard-server/src/Wizard/Service/User/Profile/UserProfileService.hs index 9136ffce6..4aba4c468 100644 --- a/wizard-server/src/Wizard/Service/User/Profile/UserProfileService.hs +++ b/wizard-server/src/Wizard/Service/User/Profile/UserProfileService.hs @@ -1,28 +1,41 @@ module Wizard.Service.User.Profile.UserProfileService where +import Control.Monad (forM_, when) +import Control.Monad.Except (throwError) import Control.Monad.Reader (asks, liftIO) +import Data.Char (toLower) import Data.Foldable (traverse_) import Data.Time import qualified Data.UUID as U import Shared.Common.Model.Common.SensitiveData +import Shared.Common.Model.Error.Error +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink import Wizard.Api.Resource.User.UserDTO import Wizard.Api.Resource.User.UserPasswordDTO import Wizard.Api.Resource.User.UserProfileChangeDTO import Wizard.Database.DAO.User.UserDAO import Wizard.Database.DAO.User.UserSubmissionPropDAO +import Wizard.Database.Mapping.UserEmailLink.UserEmailLinkType () import Wizard.Model.Config.ServerConfig import Wizard.Model.Context.AppContext import Wizard.Model.Context.AppContextHelpers +import Wizard.Model.Tenant.Config.TenantConfig import Wizard.Model.User.User import Wizard.Model.User.UserSubmissionPropEM () import Wizard.Model.User.UserSubmissionPropList +import Wizard.Model.UserEmailLink.UserEmailLinkType +import Wizard.Service.Mail.Mailer +import Wizard.Service.Tenant.Config.ConfigService import Wizard.Service.User.Profile.UserProfileMapper import Wizard.Service.User.Profile.UserProfileValidation import Wizard.Service.User.UserMapper import Wizard.Service.User.UserService import Wizard.Service.User.UserValidation +import Wizard.Service.UserEmailLink.UserEmailLinkService import WizardLib.Public.Api.Resource.User.UserLocaleDTO +import WizardLib.Public.Localization.Messages.Public getUserProfile :: AppContextM UserDTO getUserProfile = getCurrentUser @@ -31,15 +44,30 @@ modifyUserProfile :: UserProfileChangeDTO -> AppContextM UserDTO modifyUserProfile reqDto = do currentUser <- getCurrentUser user <- findUserByUuid currentUser.uuid - validateUserChangedEmailUniqueness reqDto.email user.email + let newEmail = toLower <$> reqDto.email + let emailChanged = newEmail /= user.email + let revertPending = not emailChanged && maybe False (/= user.email) user.emailPending + when emailChanged $ validateUserChangedEmailUniqueness reqDto.email user.email now <- liftIO getCurrentTime - let updatedUser = fromUserProfileChangeDTO user reqDto now + let updatedUser = fromUserProfileChangeDTO reqDto user revertPending now updateUserByUuid updatedUser + when revertPending $ do + mUserEmailLink :: Maybe (UserEmailLink U.UUID UserEmailLinkType) <- + findUserEmailLinkByIdentityAndType' (U.toString currentUser.uuid) EmailChangeUserEmailLinkType + forM_ mUserEmailLink $ \ak -> deleteUserEmailLinkByHash ak.hash + when emailChanged $ do + tenantUuid <- asks currentTenantUuid + userEmailLink <- createUserEmailLink currentUser.uuid EmailChangeUserEmailLinkType tenantUuid + sendEmailChangeMail updatedUser userEmailLink.hash newEmail return . toDTO $ updatedUser changeUserProfilePassword :: U.UUID -> UserPasswordDTO -> AppContextM () changeUserProfilePassword userUuid reqDto = do + tcAuthentication <- getCurrentTenantConfigAuthentication user <- findUserByUuid userUuid + when (not tcAuthentication.internal.nonAdminLoginEnabled && user.uRole /= _USER_ROLE_ADMIN) $ + throwError . UserError $ + _ERROR_SERVICE_TOKEN__INCORRECT_EMAIL_OR_PASSWORD passwordHash <- generatePasswordHash reqDto.password now <- liftIO getCurrentTime updateUserPasswordByUuid userUuid passwordHash now diff --git a/wizard-server/src/Wizard/Service/User/RegistrationPending/UserRegistrationPendingService.hs b/wizard-server/src/Wizard/Service/User/RegistrationPending/UserRegistrationPendingService.hs new file mode 100644 index 000000000..231c053ce --- /dev/null +++ b/wizard-server/src/Wizard/Service/User/RegistrationPending/UserRegistrationPendingService.hs @@ -0,0 +1,113 @@ +module Wizard.Service.User.RegistrationPending.UserRegistrationPendingService ( + completeExternalRegistration, + cleanUserRegistrationPending, +) where + +import Control.Monad (void, when) +import Control.Monad.Except (catchError, throwError) +import Control.Monad.Reader (asks, liftIO) +import Data.Char (toLower) +import Data.Time +import qualified Data.UUID as U + +import Shared.Common.Model.Error.Error +import Shared.Common.Util.Uuid +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink +import Wizard.Database.DAO.Common +import Wizard.Database.DAO.User.UserDAO +import Wizard.Database.Mapping.User.UserRegistrationPendingServiceType () +import Wizard.Localization.Messages.Internal +import Wizard.Localization.Messages.Public +import Wizard.Model.Context.AppContext +import Wizard.Model.Tenant.Config.TenantConfig +import Wizard.Model.User.User +import Wizard.Model.User.UserRegistrationPendingServiceType +import Wizard.Model.UserEmailLink.UserEmailLinkType +import Wizard.Service.Mail.Mailer +import Wizard.Service.Tenant.Config.ConfigService +import Wizard.Service.Tenant.Limit.LimitService +import Wizard.Service.Tenant.TenantHelper +import Wizard.Service.User.UserMapper +import Wizard.Service.User.UserService +import Wizard.Service.User.UserValidation +import Wizard.Service.UserEmailLink.UserEmailLinkService +import Wizard.Service.UserToken.Login.LoginService +import Wizard.Service.UserToken.Login.LoginValidation +import WizardLib.Public.Api.Resource.User.UserFromExternalDTO +import WizardLib.Public.Api.Resource.UserToken.UserTokenDTO +import WizardLib.Public.Database.DAO.User.UserOpenIdIdentityDAO +import WizardLib.Public.Database.DAO.User.UserRegistrationPendingDAO +import WizardLib.Public.Model.User.UserRegistrationPending +import qualified WizardLib.Public.Service.User.UserOpenIdIdentityMapper as UserOpenIdIdentityMapper +import WizardLib.Public.Service.User.UserRegistrationPendingService (cleanUserRegistrationPending) + +completeExternalRegistration :: UserFromExternalDTO -> Maybe String -> Maybe String -> AppContextM UserTokenDTO +completeExternalRegistration reqDto _mAcceptLanguages mUserAgent = + runInTransaction $ do + (pending :: UserRegistrationPending UserRegistrationPendingServiceType) <- + findUserRegistrationPendingByHash reqDto.hash + now <- liftIO getCurrentTime + tenantUuid <- asks currentTenantUuid + case pending.email of + Just idpEmail -> + when (fmap toLower idpEmail /= fmap toLower reqDto.email) $ + throwError . UserError $ + _ERROR_VALIDATION__USER_EMAIL_FROM_IDP_CANNOT_BE_CHANGED + Nothing -> return () + validateUserEmailUniqueness reqDto.email tenantUuid + let emailVerified = case pending.email of + Just _ -> True + Nothing -> False + user <- createUserForPending pending reqDto emailVerified now + identityUuid <- liftIO generateUuid + let identity = UserOpenIdIdentityMapper.fromPending identityUuid pending (user :: User).uuid now + void $ insertUserOpenIdIdentity identity + deleteUserRegistrationPendingByHash reqDto.hash + if emailVerified + then do + tcAuthentication <- getCurrentTenantConfigAuthentication + validateLoginEnabled tcAuthentication user + createLoginToken user mUserAgent Nothing + else do + userEmailLink <- createUserEmailLink (user :: User).uuid RegistrationUserEmailLinkType tenantUuid + clientUrl <- getClientUrl + catchError + (sendRegistrationConfirmationMail user userEmailLink.hash clientUrl) + (\_ -> throwError $ GeneralServerError _ERROR_SERVICE_USER__ACTIVATION_EMAIL_NOT_SENT) + return EmailVerificationRequiredDTO + +-- -------------------------------- +-- PRIVATE +-- -------------------------------- +createUserForPending + :: UserRegistrationPending UserRegistrationPendingServiceType + -> UserFromExternalDTO + -> Bool + -> UTCTime + -> AppContextM User +createUserForPending pending reqDto emailVerified now = do + checkUserLimit + checkActiveUserLimit + serverConfig <- asks serverConfig + tenantUuid <- asks currentTenantUuid + uUuid <- liftIO generateUuid + password <- liftIO . fmap U.toString $ generateUuid + uPasswordHash <- generatePasswordHash password + tcAuthentication <- getCurrentTenantConfigAuthentication + let uRole = tcAuthentication.defaultRole + let uPerms = getPermissionForRole serverConfig uRole + let user = + fromUserExternalDTO + uUuid + reqDto.firstName + reqDto.lastName + (toLower <$> reqDto.email) + uPasswordHash + uRole + uPerms + emailVerified + pending.imageUrl + tenantUuid + now + insertUser user + return user diff --git a/wizard-server/src/Wizard/Service/User/UserMapper.hs b/wizard-server/src/Wizard/Service/User/UserMapper.hs index 93a07efc9..d3437a3e9 100644 --- a/wizard-server/src/Wizard/Service/User/UserMapper.hs +++ b/wizard-server/src/Wizard/Service/User/UserMapper.hs @@ -2,7 +2,6 @@ module Wizard.Service.User.UserMapper where import qualified Data.Aeson as A import Data.Char (toLower) -import qualified Data.List as L import qualified Data.Map.Strict as M import Data.Time import qualified Data.UUID as U @@ -29,7 +28,6 @@ toDTO user = , lastName = user.lastName , email = user.email , affiliation = user.affiliation - , sources = user.sources , uRole = user.uRole , permissions = user.permissions , active = user.active @@ -38,6 +36,8 @@ toDTO user = , lastSeenNewsId = user.lastSeenNewsId , createdAt = user.createdAt , updatedAt = user.updatedAt + , emailVerifiedAt = user.emailVerifiedAt + , emailPending = user.emailPending } toUserProfile :: UserDTO -> [U.UUID] -> M.Map U.UUID A.Value -> UserProfile @@ -53,6 +53,8 @@ toUserProfile user userGroupUuids pluginSettings = , lastSeenNewsId = user.lastSeenNewsId , userGroupUuids = userGroupUuids , pluginSettings = pluginSettings + , emailVerifiedAt = user.emailVerifiedAt + , emailPending = user.emailPending } toSimple :: User -> UserSimple @@ -124,26 +126,28 @@ toAnonymousOnlineUserInfo avatarNumber colorNumber = fromUserCreateDTO :: UserCreateDTO -> U.UUID -> String -> String -> [String] -> U.UUID -> UTCTime -> Bool -> User fromUserCreateDTO dto userUuid passwordHash role permissions tenantUuid now shouldSendRegistrationEmail = - User - { uuid = userUuid - , firstName = dto.firstName - , lastName = dto.lastName - , email = toLower <$> dto.email - , passwordHash = passwordHash - , affiliation = dto.affiliation - , sources = [_USER_SOURCE_INTERNAL] - , uRole = role - , permissions = permissions - , active = not shouldSendRegistrationEmail - , imageUrl = Nothing - , locale = Nothing - , machine = False - , lastSeenNewsId = Nothing - , tenantUuid = tenantUuid - , lastVisitedAt = now - , createdAt = now - , updatedAt = now - } + let active = not shouldSendRegistrationEmail + in User + { uuid = userUuid + , firstName = dto.firstName + , lastName = dto.lastName + , email = toLower <$> dto.email + , passwordHash = passwordHash + , affiliation = dto.affiliation + , uRole = role + , permissions = permissions + , active = active + , imageUrl = Nothing + , locale = Nothing + , machine = False + , lastSeenNewsId = Nothing + , tenantUuid = tenantUuid + , lastVisitedAt = now + , createdAt = now + , updatedAt = now + , emailVerifiedAt = if active then Just now else Nothing + , emailPending = if active then Nothing else Just (toLower <$> dto.email) + } fromUserExternalDTO :: U.UUID @@ -151,7 +155,6 @@ fromUserExternalDTO -> String -> String -> String - -> [String] -> String -> [String] -> Bool @@ -159,7 +162,7 @@ fromUserExternalDTO -> U.UUID -> UTCTime -> User -fromUserExternalDTO userUuid firstName lastName email passwordHash sources uRole permissions active mImageUrl tenantUuid now = +fromUserExternalDTO userUuid firstName lastName email passwordHash uRole permissions active mImageUrl tenantUuid now = User { uuid = userUuid , firstName = firstName @@ -167,7 +170,6 @@ fromUserExternalDTO userUuid firstName lastName email passwordHash sources uRole , email = email , passwordHash = passwordHash , affiliation = Nothing - , sources = sources , uRole = uRole , permissions = permissions , active = active @@ -179,32 +181,8 @@ fromUserExternalDTO userUuid firstName lastName email passwordHash sources uRole , lastVisitedAt = now , createdAt = now , updatedAt = now - } - -fromUpdateUserExternalDTO :: User -> String -> String -> Maybe String -> String -> UTCTime -> User -fromUpdateUserExternalDTO oldUser firstName lastName mImageUrl serviceId now = - User - { uuid = oldUser.uuid - , firstName = firstName - , lastName = lastName - , email = oldUser.email - , passwordHash = oldUser.passwordHash - , affiliation = oldUser.affiliation - , sources = - case L.find (== serviceId) oldUser.sources of - Just _ -> oldUser.sources - Nothing -> oldUser.sources ++ [serviceId] - , uRole = oldUser.uRole - , permissions = oldUser.permissions - , active = oldUser.active - , imageUrl = mImageUrl - , locale = oldUser.locale - , machine = oldUser.machine - , lastSeenNewsId = oldUser.lastSeenNewsId - , tenantUuid = oldUser.tenantUuid - , lastVisitedAt = now - , createdAt = oldUser.createdAt - , updatedAt = oldUser.updatedAt + , emailVerifiedAt = if active then Just now else Nothing + , emailPending = if active then Nothing else Just email } fromUserChangeDTO :: UserChangeDTO -> User -> [String] -> User @@ -216,7 +194,6 @@ fromUserChangeDTO dto oldUser permission = , email = toLower <$> dto.email , passwordHash = oldUser.passwordHash , affiliation = dto.affiliation - , sources = oldUser.sources , uRole = dto.uRole , permissions = permission , active = dto.active @@ -228,6 +205,8 @@ fromUserChangeDTO dto oldUser permission = , lastVisitedAt = oldUser.lastVisitedAt , createdAt = oldUser.createdAt , updatedAt = oldUser.updatedAt + , emailVerifiedAt = oldUser.emailVerifiedAt + , emailPending = oldUser.emailPending } fromTenantCreateToUserCreateDTO :: TenantCreateDTO -> UserCreateDTO @@ -250,7 +229,6 @@ fromCommandCreateDTO command permissions now = , email = command.email , passwordHash = "no-hash" , affiliation = command.affiliation - , sources = command.sources , uRole = command.uRole , permissions = permissions , active = command.active @@ -262,6 +240,8 @@ fromCommandCreateDTO command permissions now = , lastVisitedAt = now , createdAt = now , updatedAt = now + , emailVerifiedAt = Just now + , emailPending = Nothing } fromCommandChangeDTO :: User -> CreateOrUpdateUserCommand -> [String] -> UTCTime -> User @@ -273,7 +253,6 @@ fromCommandChangeDTO oldUser command permissions now = , email = command.email , passwordHash = oldUser.passwordHash , affiliation = command.affiliation - , sources = command.sources , uRole = command.uRole , permissions = permissions , active = command.active @@ -285,4 +264,6 @@ fromCommandChangeDTO oldUser command permissions now = , lastVisitedAt = oldUser.lastVisitedAt , createdAt = oldUser.createdAt , updatedAt = now + , emailVerifiedAt = oldUser.emailVerifiedAt + , emailPending = oldUser.emailPending } diff --git a/wizard-server/src/Wizard/Service/User/UserService.hs b/wizard-server/src/Wizard/Service/User/UserService.hs index f5b54ffcc..502ce38f7 100644 --- a/wizard-server/src/Wizard/Service/User/UserService.hs +++ b/wizard-server/src/Wizard/Service/User/UserService.hs @@ -1,6 +1,6 @@ module Wizard.Service.User.UserService where -import Control.Monad (void, when) +import Control.Monad (unless, void, when) import Control.Monad.Except (catchError, throwError) import Control.Monad.Reader (asks, liftIO) import qualified Crypto.PasswordStore as PasswordStore @@ -9,9 +9,6 @@ import Data.Maybe (fromMaybe) import Data.Time import qualified Data.UUID as U -import Shared.ActionKey.Api.Resource.ActionKey.ActionKeyDTO -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO -import Shared.ActionKey.Model.ActionKey.ActionKey import Shared.Common.Model.Common.Page import Shared.Common.Model.Common.Pageable import Shared.Common.Model.Common.Sort @@ -21,6 +18,9 @@ import Shared.Common.Model.Error.Error import Shared.Common.Util.Crypto (generateRandomString) import Shared.Common.Util.String import Shared.Common.Util.Uuid +import Shared.UserEmailLink.Api.Resource.UserEmailLink.UserEmailLinkDTO +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink import Wizard.Api.Resource.Auth.AuthConsentDTO import Wizard.Api.Resource.User.UserChangeDTO import Wizard.Api.Resource.User.UserCreateDTO @@ -28,15 +28,14 @@ import Wizard.Api.Resource.User.UserDTO import Wizard.Api.Resource.User.UserPasswordDTO import Wizard.Database.DAO.Common import Wizard.Database.DAO.User.UserDAO -import Wizard.Database.Mapping.ActionKey.ActionKeyType () +import Wizard.Database.Mapping.UserEmailLink.UserEmailLinkType () import Wizard.Localization.Messages.Internal -import Wizard.Model.ActionKey.ActionKeyType import Wizard.Model.Config.ServerConfig import Wizard.Model.Context.AclContext import Wizard.Model.Context.AppContext import Wizard.Model.Tenant.Config.TenantConfig import Wizard.Model.User.UserSubmissionPropEM () -import Wizard.Service.ActionKey.ActionKeyService +import Wizard.Model.UserEmailLink.UserEmailLinkType import Wizard.Service.Common import Wizard.Service.Mail.Mailer import Wizard.Service.Tenant.Config.ConfigService @@ -45,11 +44,14 @@ import Wizard.Service.Tenant.TenantHelper import Wizard.Service.User.UserAudit import Wizard.Service.User.UserMapper import Wizard.Service.User.UserValidation +import Wizard.Service.UserEmailLink.UserEmailLinkService import Wizard.Service.UserToken.Login.LoginService import WizardLib.Public.Api.Resource.UserToken.UserTokenDTO -import WizardLib.Public.Localization.Messages.Public +import WizardLib.Public.Database.DAO.User.UserOpenIdIdentityDAO +import WizardLib.Public.Model.OpenId.OpenIdClient import WizardLib.Public.Model.PersistentCommand.User.CreateOrUpdateUserCommand import WizardLib.Public.Model.User.UserSuggestion +import qualified WizardLib.Public.Service.User.UserOpenIdIdentityMapper as UserOpenIdIdentityMapper getUsersPage :: Maybe String -> Maybe String -> Pageable -> [Sort] -> AppContextM (Page UserDTO) getUsersPage mQuery mRole pageable sort = do @@ -95,7 +97,13 @@ registerUser reqDto = let uPermissions = getPermissionForRole serverConfig uRole clientUrl <- getClientUrl tenantUuid <- asks currentTenantUuid - createUser reqDto uUuid uPasswordHash uRole uPermissions tenantUuid clientUrl True + mExistingUser <- findUserByEmailAndTenantUuid' (toLower reqDto.email) tenantUuid + case mExistingUser of + Just _ -> do + now <- liftIO getCurrentTime + let fakeUser = fromUserCreateDTO reqDto uUuid uPasswordHash uRole uPermissions tenantUuid now True + return $ toDTO fakeUser + Nothing -> createUser reqDto uUuid uPasswordHash uRole uPermissions tenantUuid clientUrl True createUser :: UserCreateDTO -> U.UUID -> String -> String -> [String] -> U.UUID -> String -> Bool -> AppContextM UserDTO createUser reqDto uUuid uPasswordHash uRole uPermissions tenantUuid clientUrl shouldSendRegistrationEmail = @@ -106,59 +114,61 @@ createUser reqDto uUuid uPasswordHash uRole uPermissions tenantUuid clientUrl sh now <- liftIO getCurrentTime let user = fromUserCreateDTO reqDto uUuid uPasswordHash uRole uPermissions tenantUuid now shouldSendRegistrationEmail insertUser user - actionKey <- createActionKey uUuid RegistrationActionKey tenantUuid + userEmailLink <- createUserEmailLink uUuid RegistrationUserEmailLinkType tenantUuid when shouldSendRegistrationEmail ( catchError - (sendRegistrationConfirmationMail user actionKey.hash clientUrl) + (sendRegistrationConfirmationMail user userEmailLink.hash clientUrl) (\errMessage -> throwError $ GeneralServerError _ERROR_SERVICE_USER__ACTIVATION_EMAIL_NOT_SENT) ) sendAnalyticsEmailIfEnabled user return $ toDTO user -createUserFromExternalService :: Maybe User -> String -> String -> String -> String -> Maybe String -> Maybe U.UUID -> Bool -> AppContextM User -createUserFromExternalService mUserFromDb serviceId firstName lastName email mImageUrl mUserUuid active = +createUserFromOpenIdLogin + :: OpenIdClient + -> String + -> String + -> String + -> String + -> Maybe String + -> Maybe U.UUID + -> Bool + -> AppContextM User +createUserFromOpenIdLogin openIdClient externalId firstName lastName email mImageUrl mUserUuid active = runInTransaction $ do + checkUserLimit + checkActiveUserLimit now <- liftIO getCurrentTime tenantUuid <- asks currentTenantUuid - case mUserFromDb of - Just user -> - if user.active - then do - let updatedUser = fromUpdateUserExternalDTO user firstName lastName mImageUrl serviceId now - updateUserByUuid updatedUser - return updatedUser - else throwError $ UserError _ERROR_SERVICE_TOKEN__ACCOUNT_IS_NOT_ACTIVATED - Nothing -> do - checkUserLimit - checkActiveUserLimit - serverConfig <- asks serverConfig - uUuid <- - case mUserUuid of - Just userUuid -> return userUuid - Nothing -> liftIO generateUuid - password <- liftIO $ generateRandomString 40 - uPasswordHash <- generatePasswordHash password - tcAuthentication <- getCurrentTenantConfigAuthentication - let uRole = tcAuthentication.defaultRole - let uPerms = getPermissionForRole serverConfig uRole - let user = - fromUserExternalDTO - uUuid - firstName - lastName - email - uPasswordHash - [serviceId] - uRole - uPerms - active - mImageUrl - tenantUuid - now - insertUser user - sendAnalyticsEmailIfEnabled user - return user + serverConfig <- asks serverConfig + uUuid <- + case mUserUuid of + Just userUuid -> return userUuid + Nothing -> liftIO generateUuid + password <- liftIO $ generateRandomString 40 + uPasswordHash <- generatePasswordHash password + tcAuthentication <- getCurrentTenantConfigAuthentication + let uRole = tcAuthentication.defaultRole + let uPerms = getPermissionForRole serverConfig uRole + let user = + fromUserExternalDTO + uUuid + firstName + lastName + email + uPasswordHash + uRole + uPerms + active + mImageUrl + tenantUuid + now + insertUser user + identityUuid <- liftIO generateUuid + let identity = UserOpenIdIdentityMapper.fromCreate identityUuid externalId Nothing user.uuid openIdClient.uuid openIdClient.tenantUuid now + _ <- insertUserOpenIdIdentity identity + sendAnalyticsEmailIfEnabled user + return user createOrUpdateUserFromCommand :: CreateOrUpdateUserCommand -> AppContextM User createOrUpdateUserFromCommand command = @@ -222,42 +232,80 @@ changeUserPasswordByAdmin userUuid reqDto = changeUserPasswordByHash :: U.UUID -> String -> UserPasswordDTO -> AppContextM () changeUserPasswordByHash userUuid hash userPasswordDto = runInTransaction $ do - actionKey <- findActionKeyByHash hash :: AppContextM (ActionKey U.UUID ActionKeyType) - user <- findUserByUuid actionKey.identity + userEmailLink <- findUserEmailLinkByHash hash :: AppContextM (UserEmailLink U.UUID UserEmailLinkType) + validateUserEmailLinkNotExpired userEmailLink + user <- findUserByUuid userEmailLink.identity passwordHash <- generatePasswordHash userPasswordDto.password now <- liftIO getCurrentTime updateUserPasswordByUuid userUuid passwordHash now - deleteActionKeyByHash actionKey.hash + deleteUserEmailLinkByHash userEmailLink.hash return () -resetUserPassword :: ActionKeyDTO ActionKeyType -> AppContextM () +resetUserPassword :: UserEmailLinkDTO UserEmailLinkType -> AppContextM () resetUserPassword reqDto = runInTransaction $ do mUser <- findUserByEmail' (toLower reqDto.email) case mUser of Just user -> do - tenantUuid <- asks currentTenantUuid - actionKey <- createActionKey user.uuid ForgottenPasswordActionKey tenantUuid - catchError - (sendResetPasswordMail (toDTO user) actionKey.hash) - (\errMessage -> throwError $ GeneralServerError _ERROR_SERVICE_USER__RECOVERY_EMAIL_NOT_SENT) + tcAuthentication <- getCurrentTenantConfigAuthentication + unless (not tcAuthentication.internal.nonAdminLoginEnabled && user.uRole /= _USER_ROLE_ADMIN) $ do + tenantUuid <- asks currentTenantUuid + userEmailLink <- createUserEmailLink user.uuid ForgottenPasswordUserEmailLinkType tenantUuid + catchError + (sendResetPasswordMail (toDTO user) userEmailLink.hash) + (\errMessage -> throwError $ GeneralServerError _ERROR_SERVICE_USER__RECOVERY_EMAIL_NOT_SENT) Nothing -> return () changeUserState :: String -> Bool -> AppContextM () changeUserState hash active = runInTransaction $ do checkActiveUserLimit - actionKey <- findActionKeyByHash hash :: AppContextM (ActionKey U.UUID ActionKeyType) - user <- findUserByUuid actionKey.identity - updatedUser <- updateUserTimestamp $ user {active = active} + userEmailLink <- findUserEmailLinkByHash hash :: AppContextM (UserEmailLink U.UUID UserEmailLinkType) + validateUserEmailLinkNotExpired userEmailLink + user <- findUserByUuid userEmailLink.identity + now <- liftIO getCurrentTime + let baseUser :: User + baseUser = user {active = active, updatedAt = now} + let updatedUser :: User + updatedUser = + case (userEmailLink.aType, user.emailPending) of + (RegistrationUserEmailLinkType, Just pendingEmail) -> + baseUser + { email = pendingEmail + , emailVerifiedAt = Just now + , emailPending = Nothing + } + _ -> baseUser updateUserByUuid updatedUser - deleteActionKeyByHash actionKey.hash - return () + void $ deleteUserEmailLinkByHash userEmailLink.hash + +confirmEmailChange :: String -> AppContextM () +confirmEmailChange hash = + runInTransaction $ do + userEmailLink <- findUserEmailLinkByHashAndType hash EmailChangeUserEmailLinkType :: AppContextM (UserEmailLink U.UUID UserEmailLinkType) + validateUserEmailLinkNotExpired userEmailLink + user <- findUserByUuid userEmailLink.identity + now <- liftIO getCurrentTime + case user.emailPending of + Just newEmail -> do + validateUserEmailUniqueness newEmail user.tenantUuid + let updatedUser :: User + updatedUser = + user + { email = newEmail + , emailPending = Nothing + , emailVerifiedAt = Just now + , updatedAt = now + } + updateUserByUuid updatedUser + void $ deleteUserEmailLinkByHash userEmailLink.hash + Nothing -> void $ deleteUserEmailLinkByHash userEmailLink.hash confirmConsents :: AuthConsentDTO -> Maybe String -> AppContextM UserTokenDTO confirmConsents reqDto mUserAgent = do - actionKey <- findActionKeyByHash reqDto.hash :: AppContextM (ActionKey U.UUID ActionKeyType) - user <- findUserByUuid actionKey.identity + userEmailLink <- findUserEmailLinkByHash reqDto.hash :: AppContextM (UserEmailLink U.UUID UserEmailLinkType) + validateUserEmailLinkNotExpired userEmailLink + user <- findUserByUuid userEmailLink.identity changeUserState reqDto.hash True createLoginToken user mUserAgent reqDto.sessionState diff --git a/wizard-server/src/Wizard/Service/UserEmailLink/UserEmailLinkService.hs b/wizard-server/src/Wizard/Service/UserEmailLink/UserEmailLinkService.hs new file mode 100644 index 000000000..3df7d0487 --- /dev/null +++ b/wizard-server/src/Wizard/Service/UserEmailLink/UserEmailLinkService.hs @@ -0,0 +1,52 @@ +module Wizard.Service.UserEmailLink.UserEmailLinkService where + +import Control.Monad (void, when) +import Control.Monad.Except (throwError) +import Control.Monad.Reader (liftIO) +import Data.Time +import qualified Data.UUID as U + +import Shared.Common.Localization.Messages.Public +import Shared.Common.Model.Error.Error +import Shared.Common.Util.Uuid +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink +import Wizard.Database.DAO.Common +import Wizard.Database.DAO.UserEmailLink.UserEmailLinkDAO +import Wizard.Database.Mapping.UserEmailLink.UserEmailLinkType () +import Wizard.Model.Context.AppContext (AppContextM) +import Wizard.Model.Tenant.Config.TenantConfig +import Wizard.Model.UserEmailLink.UserEmailLinkType +import Wizard.Service.Tenant.Config.ConfigService + +createUserEmailLink :: U.UUID -> UserEmailLinkType -> U.UUID -> AppContextM (UserEmailLink U.UUID UserEmailLinkType) +createUserEmailLink userUuid actionType tenantUuid = do + hash <- liftIO generateUuid + createUserEmailLinkWithHash userUuid actionType tenantUuid (U.toString hash) + +createUserEmailLinkWithHash :: U.UUID -> UserEmailLinkType -> U.UUID -> String -> AppContextM (UserEmailLink U.UUID UserEmailLinkType) +createUserEmailLinkWithHash userUuid actionType tenantUuid hash = + runInTransaction $ do + uuid <- liftIO generateUuid + now <- liftIO getCurrentTime + let userEmailLink = + UserEmailLink + { uuid = uuid + , identity = userUuid + , aType = actionType + , hash = hash + , tenantUuid = tenantUuid + , createdAt = now + } + insertUserEmailLink userEmailLink + return userEmailLink + +cleanUserEmailLinks :: AppContextM () +cleanUserEmailLinks = void deleteUserEmailLinksExpiredByTenantConfig + +validateUserEmailLinkNotExpired :: UserEmailLink identity aType -> AppContextM () +validateUserEmailLinkNotExpired userEmailLink = do + tcAuthentication <- getTenantConfigAuthenticationByUuid userEmailLink.tenantUuid + now <- liftIO getCurrentTime + let timeDelta = realToFrac . toInteger $ tcAuthentication.internal.userEmailLinkExpiration * 3600 + when (addUTCTime timeDelta userEmailLink.createdAt < now) (throwError $ UserError _ERROR_SERVICE_USER_EMAIL_LINK__EXPIRED) diff --git a/wizard-server/src/Wizard/Service/UserToken/Login/LoginService.hs b/wizard-server/src/Wizard/Service/UserToken/Login/LoginService.hs index 8fa95eb74..256ccacca 100644 --- a/wizard-server/src/Wizard/Service/UserToken/Login/LoginService.hs +++ b/wizard-server/src/Wizard/Service/UserToken/Login/LoginService.hs @@ -9,25 +9,24 @@ import Data.Time import qualified Data.UUID as U import qualified Jose.Jwt as JWT -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO -import Shared.Common.Model.Config.ServerConfig import Shared.Common.Model.Error.Error import Shared.Common.Util.Number import Shared.Common.Util.Token import Shared.Common.Util.Uuid +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO import Wizard.Database.DAO.Common import Wizard.Database.DAO.User.UserDAO -import Wizard.Model.ActionKey.ActionKeyType import Wizard.Model.Cache.ServerCache import Wizard.Model.Config.ServerConfig import Wizard.Model.Context.AppContext import Wizard.Model.Context.ContextLenses () import Wizard.Model.Tenant.Config.TenantConfig import Wizard.Model.User.User -import Wizard.Service.ActionKey.ActionKeyService +import Wizard.Model.UserEmailLink.UserEmailLinkType import Wizard.Service.Mail.Mailer import Wizard.Service.Tenant.Config.ConfigService import qualified Wizard.Service.User.UserMapper as UserMapper +import Wizard.Service.UserEmailLink.UserEmailLinkService import Wizard.Service.UserToken.Login.LoginMapper import Wizard.Service.UserToken.Login.LoginValidation import WizardLib.Public.Api.Resource.UserToken.LoginDTO @@ -46,23 +45,24 @@ createLoginTokenFromCredentials reqDto mUserAgent = Just user -> do validate reqDto user tcAuthentication <- getCurrentTenantConfigAuthentication + validateLoginEnabled tcAuthentication user now <- liftIO getCurrentTime case (tcAuthentication.internal.twoFactorAuth.enabled, reqDto.code) of (False, _) -> do updateUserLastVisitedAtByUuid user.uuid now createLoginToken user mUserAgent Nothing (True, Nothing) -> do - deleteActionKeyByIdentity (U.toString user.uuid) + deleteUserEmailLinkByIdentity (U.toString user.uuid) let length = tcAuthentication.internal.twoFactorAuth.codeLength let min = 10 ^ (length - 1) let max = (10 ^ length) - 1 code <- liftIO $ generateIntInRange min max - createActionKeyWithHash user.uuid TwoFactorAuthActionKey user.tenantUuid (show code) + createUserEmailLinkWithHash user.uuid TwoFactorAuthUserEmailLinkType user.tenantUuid (show code) sendTwoFactorAuthMail (UserMapper.toDTO user) (show code) return CodeRequiredDTO (True, Just code) -> do validateCode user code tcAuthentication - deleteActionKeyByIdentityAndHash (U.toString user.uuid) (show code) + deleteUserEmailLinkByIdentityAndHash (U.toString user.uuid) (show code) updateUserLastVisitedAtByUuid user.uuid now createLoginToken user mUserAgent Nothing Nothing -> throwError $ UserError _ERROR_SERVICE_TOKEN__INCORRECT_EMAIL_OR_PASSWORD @@ -71,11 +71,13 @@ createLoginToken :: User -> Maybe String -> Maybe String -> AppContextM UserToke createLoginToken user mUserAgent mSessionState = runInTransaction $ do serverConfig <- asks serverConfig + tcAuthentication <- getCurrentTenantConfigAuthentication + let expiration = tcAuthentication.internal.sessionExpiration uuid <- liftIO generateUuid now <- liftIO getCurrentTime - let claims = toUserTokenClaims user.uuid uuid user.tenantUuid now serverConfig.jwt.expiration + let claims = toUserTokenClaims user.uuid uuid user.tenantUuid now expiration (JWT.Jwt jwtToken) <- createSignedJwtToken claims - let userToken = fromLoginDTO uuid user serverConfig.jwt.expiration serverConfig.general.secret mUserAgent mSessionState now (BS.unpack jwtToken) + let userToken = fromLoginDTO uuid user expiration serverConfig.general.secret mUserAgent mSessionState now (BS.unpack jwtToken) insertUserToken userToken return . toDTO $ userToken diff --git a/wizard-server/src/Wizard/Service/UserToken/Login/LoginValidation.hs b/wizard-server/src/Wizard/Service/UserToken/Login/LoginValidation.hs index 596ad5d4a..cf77f69c3 100644 --- a/wizard-server/src/Wizard/Service/UserToken/Login/LoginValidation.hs +++ b/wizard-server/src/Wizard/Service/UserToken/Login/LoginValidation.hs @@ -6,15 +6,15 @@ import Control.Monad.Reader (liftIO) import Data.Time import qualified Data.UUID as U -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO -import Shared.ActionKey.Model.ActionKey.ActionKey import Shared.Common.Model.Error.Error -import Wizard.Database.Mapping.ActionKey.ActionKeyType () -import Wizard.Model.ActionKey.ActionKeyType +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink +import Wizard.Database.Mapping.UserEmailLink.UserEmailLinkType () import Wizard.Model.Context.AppContext import Wizard.Model.Context.ContextLenses () import Wizard.Model.Tenant.Config.TenantConfig import Wizard.Model.User.User +import Wizard.Model.UserEmailLink.UserEmailLinkType import Wizard.Service.User.UserUtil import WizardLib.Public.Api.Resource.UserToken.LoginDTO import WizardLib.Public.Localization.Messages.Public @@ -24,6 +24,12 @@ validate reqDto user = do validateIsUserActive user validateUserPassword reqDto user +validateLoginEnabled :: TenantConfigAuthentication -> User -> AppContextM () +validateLoginEnabled tcAuthentication user = + when (not tcAuthentication.internal.nonAdminLoginEnabled && user.uRole /= _USER_ROLE_ADMIN) $ + throwError . UserError $ + _ERROR_SERVICE_TOKEN__INCORRECT_EMAIL_OR_PASSWORD + validateIsUserActive :: User -> AppContextM () validateIsUserActive user = if user.active @@ -38,10 +44,10 @@ validateUserPassword reqDto user = validateCode :: User -> Int -> TenantConfigAuthentication -> AppContextM () validateCode user code tcAuthentication = do - mActionKey <- findActionKeyByIdentityAndHash' (U.toString user.uuid) (show code) :: AppContextM (Maybe (ActionKey U.UUID ActionKeyType)) - case mActionKey of - Just actionKey -> do + mUserEmailLink <- findUserEmailLinkByIdentityAndHash' (U.toString user.uuid) (show code) :: AppContextM (Maybe (UserEmailLink U.UUID UserEmailLinkType)) + case mUserEmailLink of + Just userEmailLink -> do let timeDelta = realToFrac . toInteger $ tcAuthentication.internal.twoFactorAuth.expiration now <- liftIO getCurrentTime - when (addUTCTime timeDelta actionKey.createdAt < now) (throwError $ UserError _ERROR_SERVICE_TOKEN__CODE_IS_EXPIRED) + when (addUTCTime timeDelta userEmailLink.createdAt < now) (throwError $ UserError _ERROR_SERVICE_TOKEN__CODE_IS_EXPIRED) Nothing -> throwError $ UserError _ERROR_SERVICE_TOKEN__INCORRECT_CODE diff --git a/wizard-server/src/Wizard/Service/UserToken/System/SystemService.hs b/wizard-server/src/Wizard/Service/UserToken/System/SystemService.hs index 533f753e9..2e87c5c97 100644 --- a/wizard-server/src/Wizard/Service/UserToken/System/SystemService.hs +++ b/wizard-server/src/Wizard/Service/UserToken/System/SystemService.hs @@ -7,7 +7,6 @@ import Data.Time import qualified Jose.Jwk as JWK import qualified Jose.Jwt as JWT -import Shared.Common.Model.Config.ServerConfig import Shared.Common.Model.Error.Error import Shared.Common.Util.Uuid import Wizard.Database.DAO.Common @@ -17,7 +16,9 @@ import Wizard.Model.Cache.ServerCache import Wizard.Model.Config.ServerConfig import Wizard.Model.Context.AppContext import Wizard.Model.Context.ContextLenses () +import Wizard.Model.Tenant.Config.TenantConfig import Wizard.Model.User.User +import Wizard.Service.Tenant.Config.ConfigService import Wizard.Service.UserToken.System.SystemMapper import Wizard.Service.UserToken.System.SystemValidation import WizardLib.Public.Api.Resource.UserToken.UserTokenClaimsDTO @@ -38,11 +39,13 @@ createSystemToken token mUserAgent = Right userTokenClaims -> do serverConfig <- asks serverConfig user <- findUserByUuidAndTenantUuidSystem userTokenClaims.userUuid userTokenClaims.tenantUuid + tcAuthentication <- getTenantConfigAuthenticationByUuid user.tenantUuid + let expiration = tcAuthentication.internal.sessionExpiration uuid <- liftIO generateUuid updateUserLastVisitedAtByUuid user.uuid now - let claims = toUserTokenClaims user.uuid uuid user.tenantUuid now serverConfig.jwt.expiration + let claims = toUserTokenClaims user.uuid uuid user.tenantUuid now expiration (JWT.Jwt jwtToken) <- createSignedJwtToken claims - let userToken = fromSystemDTO uuid user serverConfig.jwt.expiration serverConfig.general.secret mUserAgent Nothing now (BS.unpack jwtToken) + let userToken = fromSystemDTO uuid user expiration serverConfig.general.secret mUserAgent Nothing now (BS.unpack jwtToken) insertUserToken userToken return . toDTO $ userToken Left error -> throwError . UnauthorizedError $ error diff --git a/wizard-server/src/Wizard/Worker/CronWorkers.hs b/wizard-server/src/Wizard/Worker/CronWorkers.hs index 71c0ce388..e875bc889 100644 --- a/wizard-server/src/Wizard/Worker/CronWorkers.hs +++ b/wizard-server/src/Wizard/Worker/CronWorkers.hs @@ -2,7 +2,6 @@ module Wizard.Worker.CronWorkers where import Shared.Common.Database.VacuumCleaner import Shared.Common.Model.Config.ServerConfig -import Shared.PersistentCommand.Service.PersistentCommand.PersistentCommandService import Shared.Worker.Model.Worker.CronWorker import Wizard.Cache.CacheUtil import Wizard.Model.Cache.ServerCache @@ -10,7 +9,6 @@ import Wizard.Model.Config.ServerConfig import Wizard.Model.Context.AppContext import Wizard.Model.Context.BaseContext import Wizard.Model.Context.ContextLenses () -import Wizard.Service.ActionKey.ActionKeyService import Wizard.Service.Document.DocumentCleanService import Wizard.Service.Feedback.FeedbackService import Wizard.Service.KnowledgeModel.Editor.Event.EditorEventService hiding (squash) @@ -19,13 +17,16 @@ import Wizard.Service.Project.Comment.ProjectCommentService import Wizard.Service.Project.Event.ProjectEventService hiding (squash) import Wizard.Service.Project.ProjectService import Wizard.Service.Registry.Synchronization.RegistrySynchronizationService +import Wizard.Service.User.RegistrationPending.UserRegistrationPendingService +import Wizard.Service.UserEmailLink.UserEmailLinkService import Wizard.Service.UserToken.ApiKey.ApiKeyService +import WizardLib.Public.Service.PersistentCommand.PersistentCommandService import WizardLib.Public.Service.TemporaryFile.TemporaryFileService import WizardLib.Public.Service.UserToken.UserTokenService workers :: [CronWorker BaseContext AppContextM] workers = - [ actionKeyWorker + [ userEmailLinkWorker , cacheWorker , documentWorker , feedbackWorker @@ -37,20 +38,21 @@ workers = , assigneeNotificationWorker , registrySyncWorker , temporaryFileWorker + , cleanUserRegistrationPendingWorker , cleanUserTokenWorker , expireUserTokenWorker , vacuumCleanerWorker ] -- ------------------------------------------------------------------ -actionKeyWorker :: CronWorker BaseContext AppContextM -actionKeyWorker = +userEmailLinkWorker :: CronWorker BaseContext AppContextM +userEmailLinkWorker = CronWorker - { name = "ActionKeyWorker" - , condition = (.serverConfig.actionKey.clean.enabled) + { name = "UserEmailLinkWorker" + , condition = (.serverConfig.userEmailLink.clean.enabled) , cronDefault = "20 0 * * *" - , cron = (.serverConfig.actionKey.clean.cron) - , function = cleanActionKeys + , cron = (.serverConfig.userEmailLink.clean.cron) + , function = cleanUserEmailLinks , wrapInTransaction = True } @@ -186,6 +188,17 @@ cleanUserTokenWorker = , wrapInTransaction = True } +cleanUserRegistrationPendingWorker :: CronWorker BaseContext AppContextM +cleanUserRegistrationPendingWorker = + CronWorker + { name = "CleanUserRegistrationPendingWorker" + , condition = (.serverConfig.userEmailLink.clean.enabled) + , cronDefault = "30 0 * * *" + , cron = (.serverConfig.userEmailLink.clean.cron) + , function = cleanUserRegistrationPending + , wrapInTransaction = True + } + expireUserTokenWorker :: CronWorker BaseContext AppContextM expireUserTokenWorker = CronWorker diff --git a/wizard-server/test/Spec.hs b/wizard-server/test/Spec.hs index 0dcdc8150..c59dce631 100644 --- a/wizard-server/test/Spec.hs +++ b/wizard-server/test/Spec.hs @@ -1,6 +1,8 @@ module Main where import Control.Concurrent.MVar +import Control.Monad ((>=>)) +import qualified Data.ByteString as BS import Data.Maybe (fromJust) import Data.Pool import qualified Data.UUID as U @@ -41,6 +43,7 @@ import Wizard.Specs.API.KnowledgeModelEditor.APISpec import Wizard.Specs.API.KnowledgeModelPackage.APISpec import Wizard.Specs.API.KnowledgeModelSecret.APISpec import Wizard.Specs.API.Locale.APISpec +import Wizard.Specs.API.OpenIdClient.APISpec import Wizard.Specs.API.Prefab.APISpec import Wizard.Specs.API.Project.APISpec import Wizard.Specs.API.ProjectCommentThread.APISpec @@ -98,7 +101,7 @@ hLoadConfig fileName loadFn callback = do callback config prepareWebApp runCallback = - hLoadConfig serverConfigFileTest (getServerConfig validateServerConfig) $ \serverConfig -> + hLoadConfig serverConfigFileTest (BS.readFile >=> getServerConfig validateServerConfig) $ \serverConfig -> hLoadConfig buildInfoConfigFileTest getBuildInfoConfig $ \buildInfoConfig -> do shutdownFlag <- newEmptyMVar putStrLn $ "ENVIRONMENT: set to " `mappend` serverConfig.general.environment @@ -196,6 +199,7 @@ main = knowledgeModelPackageAPI baseContext appContext knowledgeModelSecretAPI baseContext appContext localeAPI baseContext appContext + openIdClientAPI baseContext appContext prefabAPI baseContext appContext projectAPI baseContext appContext projectCommentThreadAPI baseContext appContext diff --git a/wizard-server/test/Wizard/Specs/API/Config/List_Bootstrap_GET.hs b/wizard-server/test/Wizard/Specs/API/Config/List_Bootstrap_GET.hs index 6dbf491fb..2cd77797c 100644 --- a/wizard-server/test/Wizard/Specs/API/Config/List_Bootstrap_GET.hs +++ b/wizard-server/test/Wizard/Specs/API/Config/List_Bootstrap_GET.hs @@ -59,7 +59,7 @@ create_test_200 title appContext authHeaders mUserProfile = -- AND: Prepare expectation let expStatus = 200 let expHeaders = resCtHeader : resCorsHeaders - let expDto = toClientConfigDTO appContext.serverConfig defaultOrganization defaultAuthentication defaultPrivacyAndSupport defaultDashboardAndLoginScreen defaultLookAndFeel defaultRegistry defaultProject defaultSubmission defaultFeatures defaultOwl mUserProfile [] [plugin1List] plugin1Dict defaultTenant + let expDto = toClientConfigDTO appContext.serverConfig defaultOrganization defaultAuthentication [] defaultPrivacyAndSupport defaultDashboardAndLoginScreen defaultLookAndFeel defaultRegistry defaultProject defaultSubmission defaultFeatures defaultOwl mUserProfile [] [plugin1List] plugin1Dict defaultTenant let expBody = encode expDto -- AND: Run migrations runInContextIO U.runMigration appContext diff --git a/wizard-server/test/Wizard/Specs/API/OpenIdClient/APISpec.hs b/wizard-server/test/Wizard/Specs/API/OpenIdClient/APISpec.hs new file mode 100644 index 000000000..bba4769ec --- /dev/null +++ b/wizard-server/test/Wizard/Specs/API/OpenIdClient/APISpec.hs @@ -0,0 +1,21 @@ +module Wizard.Specs.API.OpenIdClient.APISpec where + +import Test.Hspec +import Test.Hspec.Wai hiding (shouldRespondWith) + +import Wizard.Specs.API.Common + +import Wizard.Specs.API.OpenIdClient.Detail_DELETE +import Wizard.Specs.API.OpenIdClient.Detail_GET +import Wizard.Specs.API.OpenIdClient.Detail_PUT +import Wizard.Specs.API.OpenIdClient.List_GET +import Wizard.Specs.API.OpenIdClient.List_POST + +openIdClientAPI baseContext appContext = + with (startWebApp baseContext appContext) $ + describe "OPEN ID CLIENT API Spec" $ do + list_GET appContext + list_POST appContext + detail_GET appContext + detail_PUT appContext + detail_DELETE appContext diff --git a/wizard-server/test/Wizard/Specs/API/OpenIdClient/Common.hs b/wizard-server/test/Wizard/Specs/API/OpenIdClient/Common.hs new file mode 100644 index 000000000..d23ca9d14 --- /dev/null +++ b/wizard-server/test/Wizard/Specs/API/OpenIdClient/Common.hs @@ -0,0 +1,52 @@ +module Wizard.Specs.API.OpenIdClient.Common where + +import Data.Either (isRight) +import Test.Hspec +import Test.Hspec.Wai hiding (shouldRespondWith) + +import Wizard.Model.Context.AppContext () +import Wizard.Model.Context.ContextLenses () +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailDTO +import WizardLib.Public.Database.DAO.OpenId.OpenIdClientDefinitionDAO +import WizardLib.Public.Model.OpenId.OpenIdClient + +import Wizard.Specs.Common + +-- -------------------------------- +-- ASSERTS +-- -------------------------------- +assertExistenceOfOpenIdClientInDB appContext openIdClient = do + eOpenIdClient <- runInContextIO (findOpenIdClientDefinitionByUuid openIdClient.uuid) appContext + liftIO $ isRight eOpenIdClient `shouldBe` True + let (Right openIdClientFromDB) = eOpenIdClient + compareOpenIdClients openIdClientFromDB openIdClient + +-- -------------------------------- +-- COMPARATORS +-- -------------------------------- +compareOpenIdClients :: OpenIdClient -> OpenIdClient -> WaiSession st () +compareOpenIdClients resModel expModel = do + liftIO $ resModel.uuid `shouldBe` expModel.uuid + liftIO $ resModel.name `shouldBe` expModel.name + liftIO $ resModel.url `shouldBe` expModel.url + liftIO $ resModel.clientId `shouldBe` expModel.clientId + liftIO $ resModel.clientSecret `shouldBe` expModel.clientSecret + liftIO $ resModel.parameters `shouldBe` expModel.parameters + liftIO $ resModel.style `shouldBe` expModel.style + liftIO $ resModel.registrationEnabled `shouldBe` expModel.registrationEnabled + liftIO $ resModel.scopeProfile `shouldBe` expModel.scopeProfile + liftIO $ resModel.scopeEmail `shouldBe` expModel.scopeEmail + liftIO $ resModel.tenantUuid `shouldBe` expModel.tenantUuid + +compareOpenIdClientDetailDtos :: OpenIdClientDetailDTO -> OpenIdClientDetailDTO -> WaiSession st () +compareOpenIdClientDetailDtos resDto expDto = do + liftIO $ resDto.name `shouldBe` expDto.name + liftIO $ resDto.url `shouldBe` expDto.url + liftIO $ resDto.clientId `shouldBe` expDto.clientId + liftIO $ resDto.clientSecret `shouldBe` expDto.clientSecret + liftIO $ resDto.parameters `shouldBe` expDto.parameters + liftIO $ resDto.style `shouldBe` expDto.style + liftIO $ resDto.registrationEnabled `shouldBe` expDto.registrationEnabled + liftIO $ resDto.scopeProfile `shouldBe` expDto.scopeProfile + liftIO $ resDto.scopeEmail `shouldBe` expDto.scopeEmail + liftIO $ resDto.tenantUuid `shouldBe` expDto.tenantUuid diff --git a/wizard-server/test/Wizard/Specs/API/OpenIdClient/Detail_DELETE.hs b/wizard-server/test/Wizard/Specs/API/OpenIdClient/Detail_DELETE.hs new file mode 100644 index 000000000..b881078b7 --- /dev/null +++ b/wizard-server/test/Wizard/Specs/API/OpenIdClient/Detail_DELETE.hs @@ -0,0 +1,81 @@ +module Wizard.Specs.API.OpenIdClient.Detail_DELETE ( + detail_DELETE, +) where + +import Network.HTTP.Types +import Network.Wai (Application) +import Test.Hspec +import Test.Hspec.Wai hiding (shouldRespondWith) +import Test.Hspec.Wai.Matcher + +import Wizard.Model.Context.AppContext +import WizardLib.Public.Database.DAO.OpenId.OpenIdClientDefinitionDAO (findOpenIdClientDefinitions) +import qualified WizardLib.Public.Database.Migration.Development.OpenId.OpenIdClientMigration as OPENID_Migration + +import SharedTest.Specs.API.Common +import Wizard.Specs.API.Common +import Wizard.Specs.Common + +-- ------------------------------------------------------------------------ +-- DELETE /wizard-api/open-id-clients/{uuid} +-- ------------------------------------------------------------------------ +detail_DELETE :: AppContext -> SpecWith ((), Application) +detail_DELETE appContext = + describe "DELETE /wizard-api/open-id-clients/{uuid}" $ do + test_204 appContext + test_401 appContext + test_403 appContext + test_404 appContext + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +reqMethod = methodDelete + +reqUrl = "/wizard-api/open-id-clients/cb7558d8-5e78-4494-9b94-0e9d64676923" + +reqHeaders = [reqAuthHeader] + +reqBody = "" + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_204 appContext = + it "HTTP 204 NO CONTENT" $ do + -- GIVEN: Prepare expectation + let expStatus = 204 + let expHeaders = resCorsHeaders + let expBody = "" + -- AND: Run migrations + runInContextIO OPENID_Migration.runMigration appContext + -- WHEN: Call API + response <- request reqMethod reqUrl reqHeaders reqBody + -- THEN: Compare response with expectation + let responseMatcher = + ResponseMatcher {matchHeaders = expHeaders, matchStatus = expStatus, matchBody = bodyEquals expBody} + response `shouldRespondWith` responseMatcher + -- AND: Find result in DB and compare with expectation state + assertCountInDB findOpenIdClientDefinitions appContext 0 + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_401 appContext = createAuthTest reqMethod reqUrl [] reqBody + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_403 appContext = createNoPermissionTest appContext reqMethod reqUrl [reqCtHeader] reqBody "CFG_PERM" + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_404 appContext = + createNotFoundTest' + reqMethod + "/wizard-api/open-id-clients/99193032-99e3-4676-acd8-222983ea0b88" + reqHeaders + reqBody + "openid_client" + [("uuid", "99193032-99e3-4676-acd8-222983ea0b88")] diff --git a/wizard-server/test/Wizard/Specs/API/OpenIdClient/Detail_GET.hs b/wizard-server/test/Wizard/Specs/API/OpenIdClient/Detail_GET.hs new file mode 100644 index 000000000..4b0e20ffd --- /dev/null +++ b/wizard-server/test/Wizard/Specs/API/OpenIdClient/Detail_GET.hs @@ -0,0 +1,82 @@ +module Wizard.Specs.API.OpenIdClient.Detail_GET ( + detail_GET, +) where + +import Data.Aeson (encode) +import Network.HTTP.Types +import Network.Wai (Application) +import Test.Hspec +import Test.Hspec.Wai hiding (shouldRespondWith) +import Test.Hspec.Wai.Matcher + +import Wizard.Model.Context.AppContext +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailJM () +import WizardLib.Public.Database.Migration.Development.OpenId.Data.OpenIdClients +import qualified WizardLib.Public.Database.Migration.Development.OpenId.OpenIdClientMigration as OPENID_Migration + +import SharedTest.Specs.API.Common +import Wizard.Specs.API.Common +import Wizard.Specs.Common + +-- ------------------------------------------------------------------------ +-- GET /wizard-api/open-id-clients/{uuid} +-- ------------------------------------------------------------------------ +detail_GET :: AppContext -> SpecWith ((), Application) +detail_GET appContext = + describe "GET /wizard-api/open-id-clients/{uuid}" $ do + test_200 appContext + test_401 appContext + test_403 appContext + test_404 appContext + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +reqMethod = methodGet + +reqUrl = "/wizard-api/open-id-clients/cb7558d8-5e78-4494-9b94-0e9d64676923" + +reqHeaders = [reqAuthHeader] + +reqBody = "" + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_200 appContext = + it "HTTP 200 OK" $ do + -- GIVEN: Prepare expectation + let expStatus = 200 + let expHeaders = resCtHeader : resCorsHeaders + let expDto = defaultOpenIdClientDetailDto + let expBody = encode expDto + -- AND: Run migrations + runInContextIO OPENID_Migration.runMigration appContext + -- WHEN: Call API + response <- request reqMethod reqUrl reqHeaders reqBody + -- THEN: Compare response with expectation + let responseMatcher = + ResponseMatcher {matchHeaders = expHeaders, matchStatus = expStatus, matchBody = bodyEquals expBody} + response `shouldRespondWith` responseMatcher + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_401 appContext = createAuthTest reqMethod reqUrl [] reqBody + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_403 appContext = createNoPermissionTest appContext reqMethod reqUrl [] reqBody "CFG_PERM" + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_404 appContext = + createNotFoundTest' + reqMethod + "/wizard-api/open-id-clients/99193032-99e3-4676-acd8-222983ea0b88" + reqHeaders + reqBody + "openid_client" + [("uuid", "99193032-99e3-4676-acd8-222983ea0b88")] diff --git a/wizard-server/test/Wizard/Specs/API/OpenIdClient/Detail_PUT.hs b/wizard-server/test/Wizard/Specs/API/OpenIdClient/Detail_PUT.hs new file mode 100644 index 000000000..42537427f --- /dev/null +++ b/wizard-server/test/Wizard/Specs/API/OpenIdClient/Detail_PUT.hs @@ -0,0 +1,88 @@ +module Wizard.Specs.API.OpenIdClient.Detail_PUT ( + detail_PUT, +) where + +import Data.Aeson (encode) +import Network.HTTP.Types +import Network.Wai (Application) +import Test.Hspec +import Test.Hspec.Wai hiding (shouldRespondWith) + +import Wizard.Model.Context.AppContext +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeJM () +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailDTO +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailJM () +import WizardLib.Public.Database.Migration.Development.OpenId.Data.OpenIdClients +import qualified WizardLib.Public.Database.Migration.Development.OpenId.OpenIdClientMigration as OPENID_Migration + +import SharedTest.Specs.API.Common +import Wizard.Specs.API.Common +import Wizard.Specs.API.OpenIdClient.Common +import Wizard.Specs.Common + +-- ------------------------------------------------------------------------ +-- PUT /wizard-api/open-id-clients/{uuid} +-- ------------------------------------------------------------------------ +detail_PUT :: AppContext -> SpecWith ((), Application) +detail_PUT appContext = + describe "PUT /wizard-api/open-id-clients/{uuid}" $ do + test_200 appContext + test_401 appContext + test_403 appContext + test_404 appContext + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +reqMethod = methodPut + +reqUrl = "/wizard-api/open-id-clients/cb7558d8-5e78-4494-9b94-0e9d64676923" + +reqHeaders = [reqCtHeader, reqAuthHeader] + +reqDto = defaultOpenIdClientChangeDto + +reqBody = encode reqDto + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_200 appContext = + it "HTTP 200 OK" $ do + -- GIVEN: Prepare expectation + let expStatus = 200 + let expHeaders = resCtHeaderPlain : resCorsHeadersPlain + let expDto = editedOpenIdClientDetailDto + -- AND: Run migrations + runInContextIO OPENID_Migration.runMigration appContext + -- WHEN: Call API + response <- request reqMethod reqUrl reqHeaders reqBody + -- THEN: Compare response with expectation + let (status, headers, resDto) = destructResponse response :: (Int, ResponseHeaders, OpenIdClientDetailDTO) + assertResStatus status expStatus + assertResHeaders headers expHeaders + compareOpenIdClientDetailDtos resDto expDto + -- AND: Find result in DB and compare with expectation state + assertExistenceOfOpenIdClientInDB appContext editedOpenIdClient + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_401 appContext = createAuthTest reqMethod reqUrl [reqCtHeader] reqBody + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_403 appContext = createNoPermissionTest appContext reqMethod reqUrl [reqCtHeader] reqBody "CFG_PERM" + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_404 appContext = + createNotFoundTest' + reqMethod + "/wizard-api/open-id-clients/99193032-99e3-4676-acd8-222983ea0b88" + reqHeaders + reqBody + "openid_client" + [("uuid", "99193032-99e3-4676-acd8-222983ea0b88")] diff --git a/wizard-server/test/Wizard/Specs/API/OpenIdClient/List_GET.hs b/wizard-server/test/Wizard/Specs/API/OpenIdClient/List_GET.hs new file mode 100644 index 000000000..4240caf4b --- /dev/null +++ b/wizard-server/test/Wizard/Specs/API/OpenIdClient/List_GET.hs @@ -0,0 +1,69 @@ +module Wizard.Specs.API.OpenIdClient.List_GET ( + list_GET, +) where + +import Data.Aeson (encode) +import Network.HTTP.Types +import Network.Wai (Application) +import Test.Hspec +import Test.Hspec.Wai hiding (shouldRespondWith) +import Test.Hspec.Wai.Matcher + +import Wizard.Model.Context.AppContext +import WizardLib.Public.Database.Migration.Development.OpenId.Data.OpenIdClients +import qualified WizardLib.Public.Database.Migration.Development.OpenId.OpenIdClientMigration as OPENID_Migration + +import SharedTest.Specs.API.Common +import Wizard.Specs.API.Common +import Wizard.Specs.Common + +-- ------------------------------------------------------------------------ +-- GET /wizard-api/open-id-clients +-- ------------------------------------------------------------------------ +list_GET :: AppContext -> SpecWith ((), Application) +list_GET appContext = + describe "GET /wizard-api/open-id-clients" $ do + test_200 appContext + test_401 appContext + test_403 appContext + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +reqMethod = methodGet + +reqUrl = "/wizard-api/open-id-clients" + +reqHeaders = [reqAuthHeader] + +reqBody = "" + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_200 appContext = + it "HTTP 200 OK" $ + -- GIVEN: Prepare expectation + do + let expStatus = 200 + let expHeaders = resCtHeader : resCorsHeaders + let expDto = [defaultOpenIdClientSimple] + let expBody = encode expDto + -- AND: Run migrations + runInContextIO OPENID_Migration.runMigration appContext + -- WHEN: Call API + response <- request reqMethod reqUrl reqHeaders reqBody + -- THEN: Compare response with expectation + let responseMatcher = + ResponseMatcher {matchHeaders = expHeaders, matchStatus = expStatus, matchBody = bodyEquals expBody} + response `shouldRespondWith` responseMatcher + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_401 appContext = createAuthTest reqMethod reqUrl [] reqBody + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_403 appContext = createNoPermissionTest appContext reqMethod reqUrl [] reqBody "CFG_PERM" diff --git a/wizard-server/test/Wizard/Specs/API/OpenIdClient/List_POST.hs b/wizard-server/test/Wizard/Specs/API/OpenIdClient/List_POST.hs new file mode 100644 index 000000000..feac65faf --- /dev/null +++ b/wizard-server/test/Wizard/Specs/API/OpenIdClient/List_POST.hs @@ -0,0 +1,84 @@ +module Wizard.Specs.API.OpenIdClient.List_POST ( + list_POST, +) where + +import Data.Aeson (encode) +import Network.HTTP.Types +import Network.Wai (Application) +import Test.Hspec +import Test.Hspec.Wai hiding (shouldRespondWith) + +import Wizard.Model.Context.AppContext +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeDTO +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientChangeJM () +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailDTO +import WizardLib.Public.Api.Resource.OpenId.Client.Definition.OpenIdClientDetailJM () +import WizardLib.Public.Database.DAO.OpenId.OpenIdClientDefinitionDAO (findOpenIdClientDefinitions) +import WizardLib.Public.Database.Migration.Development.OpenId.Data.OpenIdClients +import qualified WizardLib.Public.Database.Migration.Development.OpenId.OpenIdClientMigration as OPENID_Migration + +import SharedTest.Specs.API.Common +import Wizard.Specs.API.Common +import Wizard.Specs.API.OpenIdClient.Common +import Wizard.Specs.Common + +-- ------------------------------------------------------------------------ +-- POST /wizard-api/open-id-clients +-- ------------------------------------------------------------------------ +list_POST :: AppContext -> SpecWith ((), Application) +list_POST appContext = + describe "POST /wizard-api/open-id-clients" $ do + test_200 appContext + test_400 appContext + test_401 appContext + test_403 appContext + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +reqMethod = methodPost + +reqUrl = "/wizard-api/open-id-clients" + +reqHeaders = [reqCtHeader, reqAuthHeader] + +reqDto :: OpenIdClientChangeDTO +reqDto = defaultOpenIdClientChangeDto + +reqBody = encode reqDto + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_200 appContext = + it "HTTP 200 OK" $ do + -- GIVEN: Prepare expectation + let expStatus = 200 + let expHeaders = resCtHeaderPlain : resCorsHeadersPlain + let expDto = editedOpenIdClientDetailDto + -- AND: Run migrations + runInContextIO OPENID_Migration.runMigration appContext + -- WHEN: Call API + response <- request reqMethod reqUrl reqHeaders reqBody + -- THEN: Compare response with expectation + let (status, headers, resDto) = destructResponse response :: (Int, ResponseHeaders, OpenIdClientDetailDTO) + assertResStatus status expStatus + assertResHeaders headers expHeaders + compareOpenIdClientDetailDtos resDto expDto + -- AND: Find result in DB and compare with expectation state + assertCountInDB findOpenIdClientDefinitions appContext 2 + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_400 appContext = createInvalidJsonTest reqMethod reqUrl "name" + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_401 appContext = createAuthTest reqMethod reqUrl [reqCtHeader] reqBody + +-- ---------------------------------------------------- +-- ---------------------------------------------------- +-- ---------------------------------------------------- +test_403 appContext = createNoPermissionTest appContext reqMethod reqUrl [reqCtHeader] reqBody "CFG_PERM" diff --git a/wizard-server/test/Wizard/Specs/API/Submission/List_POST.hs b/wizard-server/test/Wizard/Specs/API/Submission/List_POST.hs index d43ca8d54..5db6fee0d 100644 --- a/wizard-server/test/Wizard/Specs/API/Submission/List_POST.hs +++ b/wizard-server/test/Wizard/Specs/API/Submission/List_POST.hs @@ -80,7 +80,7 @@ create_test_201 title appContext project authHeader user = -- AND: Prepare expectation let expStatus = 201 let expHeaders = resCtHeaderPlain : resCorsHeadersPlain - let expDto = toList submission2 defaultSubmissionService user + let expDto = toList submission2 defaultSubmissionService (Just user) let expBody = encode expDto let expType (a :: SubmissionList) = a -- AND: Run migrations diff --git a/wizard-server/test/Wizard/Specs/API/Tenant/List_POST.hs b/wizard-server/test/Wizard/Specs/API/Tenant/List_POST.hs index 8379897ba..9a4369047 100644 --- a/wizard-server/test/Wizard/Specs/API/Tenant/List_POST.hs +++ b/wizard-server/test/Wizard/Specs/API/Tenant/List_POST.hs @@ -11,11 +11,11 @@ import Test.Hspec import Test.Hspec.Wai hiding (shouldRespondWith) import Test.Hspec.Wai.Matcher -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO -import Shared.ActionKey.Model.ActionKey.ActionKey import Shared.Common.Model.Error.Error import Shared.PersistentCommand.Database.DAO.PersistentCommand.PersistentCommandDAO import Shared.PersistentCommand.Model.PersistentCommand.PersistentCommand +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink import Wizard.Api.Resource.Tenant.TenantCreateDTO import Wizard.Api.Resource.Tenant.TenantDTO import Wizard.Api.Resource.Tenant.TenantJM () @@ -23,10 +23,10 @@ import Wizard.Database.DAO.Tenant.TenantDAO import Wizard.Database.DAO.User.UserDAO import Wizard.Database.Migration.Development.Tenant.Data.Tenants import Wizard.Localization.Messages.Public -import Wizard.Model.ActionKey.ActionKeyType import Wizard.Model.Context.AppContext import Wizard.Model.Tenant.Tenant import Wizard.Model.User.User +import Wizard.Model.UserEmailLink.UserEmailLinkType import SharedTest.Specs.API.Common import Wizard.Specs.API.Common @@ -81,7 +81,7 @@ create_test_201 title appContext reqDto authHeaders persistentCommandCount userA let updatedAppContext = appContext {currentTenantUuid = tenant.uuid} (Right [user]) <- runInContextIO findUsers updatedAppContext liftIO $ user.active `shouldBe` userActive - assertCountInDB (findActionKeys :: AppContextM [ActionKey U.UUID ActionKeyType]) updatedAppContext 1 + assertCountInDB (findUserEmailLinks :: AppContextM [UserEmailLink U.UUID UserEmailLinkType]) updatedAppContext 1 assertCountInDB (findPersistentCommands :: AppContextM [PersistentCommand U.UUID]) updatedAppContext persistentCommandCount -- ---------------------------------------------------- diff --git a/wizard-server/test/Wizard/Specs/API/Token/List_POST.hs b/wizard-server/test/Wizard/Specs/API/Token/List_POST.hs index 8784d7a72..a45f784b7 100644 --- a/wizard-server/test/Wizard/Specs/API/Token/List_POST.hs +++ b/wizard-server/test/Wizard/Specs/API/Token/List_POST.hs @@ -67,7 +67,7 @@ test_400 appContext = do it "HTTP 400 BAD REQUEST when invalid credentials are provided" $ -- GIVEN: Prepare request do - let reqDto = albertCreateToken {email = "albert.einstein@example.com2"} + let reqDto = albertCreateToken {email = "albert.einstein@example.com2"} :: LoginDTO let reqBody = encode reqDto -- AND: Prepare expectation let expStatus = 400 diff --git a/wizard-server/test/Wizard/Specs/API/User/Detail_Password_Hash_PUT.hs b/wizard-server/test/Wizard/Specs/API/User/Detail_Password_Hash_PUT.hs index 22e676d76..9adfa8696 100644 --- a/wizard-server/test/Wizard/Specs/API/User/Detail_Password_Hash_PUT.hs +++ b/wizard-server/test/Wizard/Specs/API/User/Detail_Password_Hash_PUT.hs @@ -3,16 +3,18 @@ module Wizard.Specs.API.User.Detail_Password_Hash_PUT ( ) where import Data.Aeson (encode) +import Data.Time (getCurrentTime) import Network.HTTP.Types import Network.Wai (Application) import Test.Hspec import Test.Hspec.Wai hiding (shouldRespondWith) import Test.Hspec.Wai.Matcher -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink import Wizard.Api.Resource.User.UserPasswordDTO -import Wizard.Database.Migration.Development.ActionKey.Data.ActionKeys import Wizard.Database.Migration.Development.User.Data.Users +import Wizard.Database.Migration.Development.UserEmailLink.Data.UserEmailLinks import Wizard.Model.Context.AppContext import Wizard.Model.User.User @@ -51,7 +53,8 @@ test_204 appContext = it "HTTP 204 NO CONTENT" $ -- GIVEN: Prepare DB do - eitherActionKey <- runInContextIO (insertActionKey forgottenPasswordActionKey) appContext + now <- liftIO getCurrentTime + eitherUserEmailLink <- runInContextIO (insertUserEmailLink (forgottenPasswordUserEmailLink {createdAt = now})) appContext -- AND: Prepare expectation let expStatus = 204 let expHeaders = resCorsHeaders @@ -78,5 +81,5 @@ test_404 appContext = "/wizard-api/users/ec6f8e90-2a91-49ec-aa3f-9eab2267fc66/password?hash=c996414a-b51d-4c8c-bc10-5ee3dab85fa8" reqHeaders reqBody - "action_key" + "user_email_link" [("hash", "c996414a-b51d-4c8c-bc10-5ee3dab85fa8")] diff --git a/wizard-server/test/Wizard/Specs/API/User/Detail_State_PUT.hs b/wizard-server/test/Wizard/Specs/API/User/Detail_State_PUT.hs index 8d6af94d2..a8f778c4d 100644 --- a/wizard-server/test/Wizard/Specs/API/User/Detail_State_PUT.hs +++ b/wizard-server/test/Wizard/Specs/API/User/Detail_State_PUT.hs @@ -3,6 +3,7 @@ module Wizard.Specs.API.User.Detail_State_PUT ( ) where import Data.Aeson (encode) +import Data.Time (getCurrentTime) import qualified Data.UUID as U import Network.HTTP.Types import Network.Wai (Application) @@ -10,14 +11,14 @@ import Test.Hspec import Test.Hspec.Wai hiding (shouldRespondWith) import Test.Hspec.Wai.Matcher -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO -import Shared.ActionKey.Model.ActionKey.ActionKey +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink import Wizard.Database.DAO.User.UserDAO -import Wizard.Database.Migration.Development.ActionKey.Data.ActionKeys import Wizard.Database.Migration.Development.User.Data.Users -import Wizard.Model.ActionKey.ActionKeyType +import Wizard.Database.Migration.Development.UserEmailLink.Data.UserEmailLinks import Wizard.Model.Context.AppContext import Wizard.Model.User.User +import Wizard.Model.UserEmailLink.UserEmailLinkType import SharedTest.Specs.API.Common import Wizard.Specs.API.Common @@ -59,7 +60,8 @@ test_200 appContext = let expDto = reqDto let expBody = encode expDto -- AND: Prepare DB - runInContextIO (insertActionKey registrationActionKey) appContext + now <- liftIO getCurrentTime + runInContextIO (insertUserEmailLink (registrationUserEmailLink {createdAt = now})) appContext runInContextIO (updateUserByUuid (userAlbert {active = False})) appContext -- WHEN: Call API response <- request reqMethod reqUrl reqHeaders reqBody @@ -68,7 +70,7 @@ test_200 appContext = ResponseMatcher {matchHeaders = expHeaders, matchStatus = expStatus, matchBody = bodyEquals expBody} response `shouldRespondWith` responseMatcher -- AND: Find result in DB and compare with expectation state - assertCountInDB (findActionKeys :: AppContextM [ActionKey U.UUID ActionKeyType]) appContext 0 + assertCountInDB (findUserEmailLinks :: AppContextM [UserEmailLink U.UUID UserEmailLinkType]) appContext 0 assertExistenceOfUserInDB appContext userAlbert -- ---------------------------------------------------- @@ -85,5 +87,5 @@ test_404 appContext = "/wizard-api/users/ec6f8e90-2a91-49ec-aa3f-9eab2267fc66/state?hash=c996414a-b51d-4c8c-bc10-5ee3dab85fa8" reqHeaders reqBody - "action_key" + "user_email_link" [("hash", "c996414a-b51d-4c8c-bc10-5ee3dab85fa8")] diff --git a/wizard-server/test/Wizard/Specs/API/User/List_Current_PUT.hs b/wizard-server/test/Wizard/Specs/API/User/List_Current_PUT.hs index 8dec13ba8..910c3e26d 100644 --- a/wizard-server/test/Wizard/Specs/API/User/List_Current_PUT.hs +++ b/wizard-server/test/Wizard/Specs/API/User/List_Current_PUT.hs @@ -3,6 +3,7 @@ module Wizard.Specs.API.User.List_Current_PUT ( ) where import Data.Aeson (encode) +import Data.Either (isRight) import qualified Data.Map.Strict as M import Network.HTTP.Types import Network.Wai (Application) @@ -15,6 +16,7 @@ import Wizard.Api.Resource.User.UserDTO import Wizard.Api.Resource.User.UserJM () import Wizard.Api.Resource.User.UserProfileChangeDTO import Wizard.Api.Resource.User.UserProfileChangeJM () +import Wizard.Database.DAO.User.UserDAO import Wizard.Database.Migration.Development.User.Data.Users import qualified Wizard.Database.Migration.Development.User.UserMigration as U_Migration import Wizard.Localization.Messages.Public @@ -59,17 +61,20 @@ test_200 appContext = do let expStatus = 200 let expHeaders = resCorsHeadersPlain - let expDto = toDTO userAlbertEdited - let expBody = encode expDto -- WHEN: Call API response <- request reqMethod reqUrl reqHeaders reqBody -- THEN: Compare response with expectation let (status, headers, resDto) = destructResponse response :: (Int, ResponseHeaders, UserDTO) + let expDto = (toDTO userAlbertEditedAfterPut) {updatedAt = resDto.updatedAt} :: UserDTO assertResStatus status expStatus assertResHeaders headers expHeaders compareUserDtos resDto expDto - -- AND: Find result in DB and compare with expectation state - assertExistenceOfUserInDB appContext userAlbertEdited + -- AND: Find result in DB and compare with expectation state (ignoring dynamic updatedAt) + eUser <- runInContextIO (findUserByUuid userAlbert.uuid) appContext + liftIO $ isRight eUser `shouldBe` True + let (Right userFromDB) = eUser + let expUser = userAlbertEditedAfterPut {updatedAt = userFromDB.updatedAt} :: User + liftIO $ userFromDB `shouldBe` expUser -- ---------------------------------------------------- -- ---------------------------------------------------- diff --git a/wizard-server/test/Wizard/Specs/API/User/List_POST.hs b/wizard-server/test/Wizard/Specs/API/User/List_POST.hs index 2a9570850..39a75a547 100644 --- a/wizard-server/test/Wizard/Specs/API/User/List_POST.hs +++ b/wizard-server/test/Wizard/Specs/API/User/List_POST.hs @@ -11,21 +11,21 @@ import Test.Hspec import Test.Hspec.Wai hiding (shouldRespondWith) import Test.Hspec.Wai.Matcher -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO -import Shared.ActionKey.Model.ActionKey.ActionKey import Shared.Common.Model.Error.Error import Shared.PersistentCommand.Database.DAO.PersistentCommand.PersistentCommandDAO import Shared.PersistentCommand.Model.PersistentCommand.PersistentCommand +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO +import Shared.UserEmailLink.Model.UserEmailLink.UserEmailLink import Wizard.Api.Resource.User.UserCreateDTO import Wizard.Api.Resource.User.UserDTO import Wizard.Api.Resource.User.UserJM () import Wizard.Database.DAO.User.UserDAO -import qualified Wizard.Database.Migration.Development.ActionKey.ActionKeyMigration as ACK import Wizard.Database.Migration.Development.User.Data.Users +import qualified Wizard.Database.Migration.Development.UserEmailLink.UserEmailLinkMigration as ACK import Wizard.Localization.Messages.Public -import Wizard.Model.ActionKey.ActionKeyType import Wizard.Model.Context.AppContext import Wizard.Model.User.User +import Wizard.Model.UserEmailLink.UserEmailLinkType import SharedTest.Specs.API.Common import Wizard.Specs.API.Common @@ -81,7 +81,7 @@ create_test_201 title appContext reqDto expDto authHeaders persistentCommandCoun assertResHeaders headers expHeaders compareUserCreateDtos resDto expDto userActive -- AND: Find result in DB and compare with expectation state - assertCountInDB (findActionKeys :: AppContextM [ActionKey U.UUID ActionKeyType]) appContext 1 + assertCountInDB (findUserEmailLinks :: AppContextM [UserEmailLink U.UUID UserEmailLinkType]) appContext 1 assertCountInDB findUsers appContext 2 assertCountInDB (findPersistentCommands :: AppContextM [PersistentCommand U.UUID]) appContext persistentCommandCount @@ -90,7 +90,6 @@ create_test_201 title appContext reqDto expDto authHeaders persistentCommandCoun -- ---------------------------------------------------- test_400 appContext = do createInvalidJsonTest reqMethod reqUrl "lastName" - create_test_400_email_uniqueness "HTTP 400 BAD REQUEST if email is already registered (anonymous)" appContext [] create_test_400_email_uniqueness "HTTP 400 BAD REQUEST if email is already registered (admin)" appContext diff --git a/wizard-server/test/Wizard/TestMigration.hs b/wizard-server/test/Wizard/TestMigration.hs index 0231b0e7e..0b7eb7a1b 100644 --- a/wizard-server/test/Wizard/TestMigration.hs +++ b/wizard-server/test/Wizard/TestMigration.hs @@ -2,7 +2,6 @@ module Wizard.TestMigration where import Data.Foldable (traverse_) -import Shared.ActionKey.Database.DAO.ActionKey.ActionKeyDAO import Shared.Audit.Database.DAO.Audit.AuditDAO import qualified Shared.Audit.Database.Migration.Development.Audit.AuditSchemaMigration as Audit import Shared.Common.Constant.Tenant @@ -16,6 +15,7 @@ import Shared.Locale.Database.DAO.Locale.LocaleDAO import Shared.PersistentCommand.Database.DAO.PersistentCommand.PersistentCommandDAO import Shared.Prefab.Database.DAO.Prefab.PrefabDAO import qualified Shared.Prefab.Database.Migration.Development.Prefab.PrefabSchemaMigration as Prefab +import Shared.UserEmailLink.Database.DAO.UserEmailLink.UserEmailLinkDAO import Wizard.Database.DAO.Document.DocumentDAO import Wizard.Database.DAO.DocumentTemplate.DocumentTemplateDraftDAO import Wizard.Database.DAO.Feedback.FeedbackDAO @@ -46,7 +46,6 @@ import Wizard.Database.DAO.Tenant.Config.TenantConfigSubmissionDAO import Wizard.Database.DAO.Tenant.TenantDAO import Wizard.Database.DAO.Tenant.TenantLimitBundleDAO import Wizard.Database.DAO.User.UserDAO -import qualified Wizard.Database.Migration.Development.ActionKey.ActionKeySchemaMigration as ActionKey import qualified Wizard.Database.Migration.Development.Common.CommonSchemaMigration as Common import qualified Wizard.Database.Migration.Development.Document.DocumentSchemaMigration as Document import qualified Wizard.Database.Migration.Development.DocumentTemplate.DocumentTemplateMigration as DocumentTemplateMigration @@ -75,6 +74,7 @@ import qualified Wizard.Database.Migration.Development.Tenant.TenantSchemaMigrat import Wizard.Database.Migration.Development.User.Data.UserTokens import Wizard.Database.Migration.Development.User.Data.Users import qualified Wizard.Database.Migration.Development.User.UserSchemaMigration as User +import qualified Wizard.Database.Migration.Development.UserEmailLink.UserEmailLinkSchemaMigration as UserEmailLink import Wizard.Model.Cache.ServerCache import Wizard.Model.Tenant.Config.TenantConfig import WizardLib.Public.Database.DAO.ExternalLink.ExternalLinkUsageDAO @@ -83,10 +83,14 @@ import WizardLib.Public.Database.DAO.Tenant.Config.TenantConfigLookAndFeelDAO import WizardLib.Public.Database.DAO.Tenant.Config.TenantConfigMailDAO import WizardLib.Public.Database.DAO.User.UserGroupDAO import WizardLib.Public.Database.DAO.User.UserGroupMembershipDAO +import WizardLib.Public.Database.DAO.User.UserOpenIdIdentityDAO import WizardLib.Public.Database.DAO.User.UserTokenDAO import WizardLib.Public.Database.DAO.User.UserTourDAO import qualified WizardLib.Public.Database.Migration.Development.ExternalLink.ExternalLinkSchemaMigration as ExternalLink +import qualified WizardLib.Public.Database.Migration.Development.OpenId.OpenIdClientSchemaMigration as OpenIdClient import WizardLib.Public.Database.Migration.Development.Tenant.Data.TenantConfigs +import qualified WizardLib.Public.Database.Migration.Development.User.UserOpenIdIdentitySchemaMigration as UserOpenIdIdentity +import qualified WizardLib.Public.Database.Migration.Development.User.UserRegistrationPendingSchemaMigration as UserRegistrationPending import WizardLib.Public.Model.Tenant.Config.TenantConfig import Wizard.Specs.Common @@ -110,7 +114,7 @@ buildSchema appContext = do runInContext Prefab.dropTables appContext runInContext PersistentCommand.dropTables appContext runInContext Submission.dropTables appContext - runInContext ActionKey.dropTables appContext + runInContext UserEmailLink.dropTables appContext runInContext Feedback.dropTables appContext runInContext KnowledgeModelMigration.dropTables appContext runInContext KnowledgeModelCache.dropTables appContext @@ -120,8 +124,11 @@ buildSchema appContext = do runInContext Project.dropTables appContext runInContext KnowledgeModelSecret.dropTables appContext runInContext KnowledgeModelPackage.dropTables appContext + runInContext UserRegistrationPending.dropTables appContext + runInContext UserOpenIdIdentity.dropTables appContext runInContext User.dropTables appContext runInContext Tenant.dropConfigTables appContext + runInContext OpenIdClient.dropTables appContext runInContext DocumentTemplate.dropTables appContext runInContext Locale.dropTables appContext runInContext Plugin.dropTables appContext @@ -139,10 +146,13 @@ buildSchema appContext = do runInContext Locale.createTables appContext runInContext DocumentTemplate.createTables appContext runInContext Tenant.createConfigTables appContext + runInContext OpenIdClient.createTables appContext runInContext User.createTables appContext + runInContext UserOpenIdIdentity.createTables appContext + runInContext UserRegistrationPending.createTables appContext runInContext KnowledgeModelPackage.createTables appContext runInContext KnowledgeModelSecret.createTables appContext - runInContext ActionKey.createTables appContext + runInContext UserEmailLink.createTables appContext runInContext Feedback.createTables appContext runInContext KnowledgeModelEditor.createTables appContext runInContext KnowledgeModelCache.createTables appContext @@ -197,7 +207,7 @@ resetDB appContext = do runInContext deleteKnowledgeModelMigrations appContext runInContext deleteProjectMigrations appContext runInContext deleteFeedbacks appContext - runInContext deleteActionKeys appContext + runInContext deleteUserEmailLinks appContext runInContext deleteKnowledgeModelEditors appContext runInContext deleteDocuments appContext runInContext deleteDrafts appContext @@ -214,6 +224,7 @@ resetDB appContext = do runInContext deletePackages appContext runInContext deleteUserTokens appContext runInContext deleteUserGroupMemberships appContext + runInContext deleteUserOpenIdIdentities appContext runInContext deleteTours appContext runInContext deleteUsers appContext runInContext deleteUserGroups appContext @@ -230,7 +241,6 @@ resetDB appContext = do runInContext (insertLimitBundle differentTenantLimitBundle) appContext runInContext (insertTenantConfigOrganization defaultOrganization) appContext runInContext (insertTenantConfigAuthentication defaultAuthenticationEncrypted) appContext - runInContext (insertTenantConfigAuthenticationExternalService defaultAuthExternalServiceEncrypted) appContext runInContext (insertTenantConfigPrivacyAndSupport defaultPrivacyAndSupport) appContext runInContext (insertTenantConfigDashboardAndLoginScreen defaultDashboardAndLoginScreen) appContext runInContext (insertTenantConfigDashboardAndLoginScreenAnnouncement defaultDashboardAndLoginScreenAnnouncement) appContext