From e3b5b93c71e49203e428382cfabb3d536f290cc4 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 8 May 2020 18:03:38 +0200 Subject: [PATCH] feat(workflows): definition route stubs & i18n --- messages/uniworx/de-de-formal.msg | 15 ++++- models/workflows.model | 19 ++++-- routes | 5 ++ src/Application.hs | 1 + src/CryptoID.hs | 1 + src/Foundation/I18n.hs | 1 + src/Foundation/Navigation.hs | 41 ++++++++++++ src/Foundation/Routes.hs | 1 + src/Handler/Utils/I18n.hs | 9 +++ src/Handler/Workflow.hs | 5 ++ src/Handler/Workflow/Definition.hs | 8 +++ src/Handler/Workflow/Definition/Delete.hs | 9 +++ src/Handler/Workflow/Definition/Edit.hs | 9 +++ src/Handler/Workflow/Definition/Form.hs | 22 ++++++ src/Handler/Workflow/Definition/List.hs | 9 +++ src/Handler/Workflow/Definition/New.hs | 9 +++ src/Model/Types/Common.hs | 6 ++ src/Model/Types/TH/JSON.hs | 5 +- src/Model/Types/Workflow.hs | 56 ++++++++++------ src/Utils.hs | 1 + src/Utils/I18n.hs | 81 +++++++++++++++++++++++ 21 files changed, 284 insertions(+), 29 deletions(-) create mode 100644 src/Handler/Workflow.hs create mode 100644 src/Handler/Workflow/Definition.hs create mode 100644 src/Handler/Workflow/Definition/Delete.hs create mode 100644 src/Handler/Workflow/Definition/Edit.hs create mode 100644 src/Handler/Workflow/Definition/Form.hs create mode 100644 src/Handler/Workflow/Definition/List.hs create mode 100644 src/Handler/Workflow/Definition/New.hs create mode 100644 src/Utils/I18n.hs diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index ff7a2f644..1ee0b58ec 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1368,6 +1368,9 @@ MenuFaq: FAQ MenuSheetPersonalisedFiles: Personalisierte Dateien herunterladen MenuCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen MenuAdminCrontab: Crontab +MenuAdminWorkflowDefinitionList: Workflows +MenuAdminWorkflowDefinitionNew: Neue Workflow-Definition +MenuAdminWorkflowDefinitionDelete: Löschen BreadcrumbSubmissionFile: Datei BreadcrumbSubmissionUserInvite: Einladung zur Abgabe @@ -1443,6 +1446,10 @@ BreadcrumbFaq: FAQ BreadcrumbSheetPersonalisedFiles: Personalisierte Dateien herunterladen BreadcrumbCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen BreadcrumbAdminCrontab: Crontab +BreadcrumbAdminWorkflowDefinitionList: Workflow-Definitionen +BreadcrumbAdminWorkflowDefinitionNew: Neue Workflow-Definition +BreadcrumbAdminWorkflowDefinitionEdit renderedWorkflowScope'@Text wfdn@WorkflowDefinitionName: #{wfdn} (#{renderedWorkflowScope'} +BreadcrumbAdminWorkflowDefinitionDelete: Löschen ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn} ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn} @@ -2765,4 +2772,10 @@ CronMatchAsap: ASAP CronMatchNone: Nie SystemExamOffice: Prüfungsverwaltung -SystemFaculty: Fakultätsmitglied \ No newline at end of file +SystemFaculty: Fakultätsmitglied + +WorkflowInstanceScopeKindGlobal: Systemweit +WorkflowInstanceScopeKindTerm: Pro Semester +WorkflowInstanceScopeKindSchool: Pro Institut +WorkflowInstanceScopeKindTermSchool: Pro Institut & Semester +WorkflowInstanceScopeKindCourse: Pro Veranstaltung diff --git a/models/workflows.model b/models/workflows.model index 011997038..09aa58f2c 100644 --- a/models/workflows.model +++ b/models/workflows.model @@ -1,19 +1,26 @@ WorkflowDefinition - graph (WorkflowGraph SqlBackendKey SqlBackendKey) + graph (WorkflowGraph SqlBackendKey SqlBackendKey) -- FileId, UserId scope WorkflowInstanceScope' - name (CI Text) + name WorkflowDefinitionName UniqueWorkflowDefinition name scope -WorkflowInstance +WorkflowDefinitionDescription definition WorkflowDefinitionId + language Lang + title Text + description Html Maybe + UniqueWorkflowDefinitionDescription definition language + +WorkflowInstance + definition WorkflowDefinitionId Maybe graph (WorkflowGraph SqlBackendKey SqlBackendKey) -- FileId, UserId scope (WorkflowInstanceScope SqlBackendKey SqlBackendKey SqlBackendKey) -- TermId, SchoolId, CourseId - name (CI Text) - category (CI Text) Maybe + name WorkflowInstanceName + category WorkflowInstanceCategory Maybe UniqueWorkflowInstance name scope WorkflowWorkflow - instance WorkflowInstanceId + instance WorkflowInstanceId Maybe graph (WorkflowGraph SqlBackendKey SqlBackendKey) -- FileId, UserId initUser UserId Maybe initTime UTCTime diff --git a/routes b/routes index 810aeb824..4e0e8986f 100644 --- a/routes +++ b/routes @@ -57,6 +57,11 @@ /admin/errMsg AdminErrMsgR GET POST /admin/tokens AdminTokensR GET POST /admin/crontab AdminCrontabR GET +/admin/workflow-definitions AdminWorkflowDefinitionListR GET +/admin/workflow-definitions/new AdminWorkflowDefinitionNewR GET POST +/admin/workflow-definitions/#WorkflowInstanceScope'/#WorkflowDefinitionName AdminWorkflowDefinitionR: + /edit AWDEditR GET POST + /delete AWDDeleteR GET POST /health HealthR GET !free /instance InstanceR GET !free diff --git a/src/Application.hs b/src/Application.hs index d4dd082fb..50feb8b4d 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -128,6 +128,7 @@ import Handler.Metrics import Handler.ExternalExam import Handler.Participants import Handler.StorageKey +import Handler.Workflow -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 8884fba25..b311d2aaa 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -73,6 +73,7 @@ decCryptoIDs [ ''SubmissionId , ''CourseEventId , ''TutorialId , ''ExternalExamId + , ''WorkflowWorkflowId ] decCryptoIDKeySize diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 71543f2d9..1b8568e78 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -225,6 +225,7 @@ embedRenderMessage ''UniWorX ''Quoting ("Csv" <>) embedRenderMessage ''UniWorX ''FavouriteReason id embedRenderMessage ''UniWorX ''Sex id embedRenderMessage ''UniWorX ''ExamGradingMode id +embedRenderMessage ''UniWorX ''WorkflowInstanceScope' $ ("WorkflowInstanceScopeKind" <>) . concat . drop 1 . splitCamel . fromMaybe (error "Expected WorkflowInstanceScope' to have '") . stripSuffix "'" embedRenderMessage ''UniWorX ''AuthenticationMode id diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index f1e8281c1..7b89706b9 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -331,6 +331,14 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR EECorrectR -> i18nCrumb MsgBreadcrumbExternalExamCorrect . Just $ EExamR tid ssh coursen examn EEShowR + breadcrumb AdminWorkflowDefinitionListR = i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionList $ Just AdminR + breadcrumb AdminWorkflowDefinitionNewR = i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionNew $ Just AdminWorkflowDefinitionListR + breadcrumb (AdminWorkflowDefinitionR wfdScope wfdName sRoute) = case sRoute of + AWDEditR -> do + MsgRenderer mr <- getMsgRenderer + i18nCrumb (MsgBreadcrumbAdminWorkflowDefinitionEdit (mr wfdScope) wfdName) $ Just AdminWorkflowDefinitionListR + AWDDeleteR -> i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionDelete . Just $ AdminWorkflowDefinitionR wfdScope wfdName AWDEditR + data NavQuickView = NavQuickViewFavourite @@ -667,6 +675,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navQuick' = mempty , navForceActive = False } + , NavLink + { navLabel = MsgMenuAdminWorkflowDefinitionList + , navRoute = AdminWorkflowDefinitionListR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } , NavLink { navLabel = MsgMenuAdminCrontab , navRoute = AdminCrontabR @@ -2271,6 +2287,31 @@ pageActions ParticipantsListR = return , navChildren = [] } ] +pageActions AdminWorkflowDefinitionListR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuAdminWorkflowDefinitionNew + , navRoute = AdminWorkflowDefinitionNewR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (AdminWorkflowDefinitionR wds wdn AWDEditR) = return + [ NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuAdminWorkflowDefinitionDelete + , navRoute = AdminWorkflowDefinitionR wds wdn AWDDeleteR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + } + ] pageActions _ = return [] submissionList :: ( MonadIO m diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index 52ca3f87c..081569d77 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -38,6 +38,7 @@ deriving instance Generic SchoolR deriving instance Generic ExamOfficeR deriving instance Generic CourseNewsR deriving instance Generic CourseEventR +deriving instance Generic AdminWorkflowDefinitionR deriving instance Generic (Route UniWorX) data RouteChildren diff --git a/src/Handler/Utils/I18n.hs b/src/Handler/Utils/I18n.hs index aaf7132f4..526238eb7 100644 --- a/src/Handler/Utils/I18n.hs +++ b/src/Handler/Utils/I18n.hs @@ -1,6 +1,7 @@ module Handler.Utils.I18n ( i18nWidgetFile , i18nWidgetFilesAvailable, i18nWidgetFilesAvailable', i18nWidgetFiles + , i18nMessage ) where import Import.NoFoundation @@ -77,3 +78,11 @@ i18nWidgetFiles basename = do , l <- unpack <$> NonEmpty.toList ls ] ++ [ clause [wildP, wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match ] [e|imap (\kind ls -> selectLanguage ls >>= $(varE ws) kind) availableTranslations'|] + + +i18nMessage :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , RenderMessage UniWorX msg + ) + => msg -> m I18nText +i18nMessage = i18nMessageFor $ toList appLanguages diff --git a/src/Handler/Workflow.hs b/src/Handler/Workflow.hs new file mode 100644 index 000000000..fcf64fb1d --- /dev/null +++ b/src/Handler/Workflow.hs @@ -0,0 +1,5 @@ +module Handler.Workflow + ( module Handler.Workflow + ) where + +import Handler.Workflow.Definition as Handler.Workflow diff --git a/src/Handler/Workflow/Definition.hs b/src/Handler/Workflow/Definition.hs new file mode 100644 index 000000000..f9e22acc3 --- /dev/null +++ b/src/Handler/Workflow/Definition.hs @@ -0,0 +1,8 @@ +module Handler.Workflow.Definition + ( module Handler.Workflow.Definition + ) where + +import Handler.Workflow.Definition.List as Handler.Workflow.Definition +import Handler.Workflow.Definition.New as Handler.Workflow.Definition +import Handler.Workflow.Definition.Edit as Handler.Workflow.Definition +import Handler.Workflow.Definition.Delete as Handler.Workflow.Definition diff --git a/src/Handler/Workflow/Definition/Delete.hs b/src/Handler/Workflow/Definition/Delete.hs new file mode 100644 index 000000000..a8bca1f3f --- /dev/null +++ b/src/Handler/Workflow/Definition/Delete.hs @@ -0,0 +1,9 @@ +module Handler.Workflow.Definition.Delete + ( getAWDDeleteR, postAWDDeleteR + ) where + +import Import + +getAWDDeleteR, postAWDDeleteR :: WorkflowInstanceScope' -> WorkflowDefinitionName -> Handler Html +getAWDDeleteR = postAWDDeleteR +postAWDDeleteR = error "not implemented" diff --git a/src/Handler/Workflow/Definition/Edit.hs b/src/Handler/Workflow/Definition/Edit.hs new file mode 100644 index 000000000..264d8b033 --- /dev/null +++ b/src/Handler/Workflow/Definition/Edit.hs @@ -0,0 +1,9 @@ +module Handler.Workflow.Definition.Edit + ( getAWDEditR, postAWDEditR + ) where + +import Import + +getAWDEditR, postAWDEditR :: WorkflowInstanceScope' -> WorkflowDefinitionName -> Handler Html +getAWDEditR = postAWDEditR +postAWDEditR = error "not implemented" diff --git a/src/Handler/Workflow/Definition/Form.hs b/src/Handler/Workflow/Definition/Form.hs new file mode 100644 index 000000000..f6176967c --- /dev/null +++ b/src/Handler/Workflow/Definition/Form.hs @@ -0,0 +1,22 @@ +module Handler.Workflow.Definition.Form + ( workflowDefinitionForm + ) where + +import Import + +import Handler.Utils + +data WorkflowDefinitionForm = WorkflowDefinitionForm + { wdfScope :: WorkflowInstanceScope' + , wdfName :: CI Text + , wdfDescriptions :: Map Lang (Text, Maybe Html) + , wdfGraph :: WorkflowGraph CryptoUUIDFile CryptoUUIDUser + } deriving (Generic, Typeable) + +workflowDefinitionForm :: Html -> MForm DB (FormResult WorkflowDefinitionForm, Widget) +workflowDefinitionForm = validateForm validateWorkflowDefinitionForm . renderAForm FormStandard $ + error "not implemented" + + +validateWorkflowDefinitionForm :: FormValidator WorkflowDefinitionForm DB () +validateWorkflowDefinitionForm = error "not implemented" diff --git a/src/Handler/Workflow/Definition/List.hs b/src/Handler/Workflow/Definition/List.hs new file mode 100644 index 000000000..9a1bc8956 --- /dev/null +++ b/src/Handler/Workflow/Definition/List.hs @@ -0,0 +1,9 @@ +module Handler.Workflow.Definition.List + ( getAdminWorkflowDefinitionListR, postAdminWorkflowDefinitionListR + ) where + +import Import + +getAdminWorkflowDefinitionListR, postAdminWorkflowDefinitionListR :: Handler Html +getAdminWorkflowDefinitionListR = postAdminWorkflowDefinitionListR +postAdminWorkflowDefinitionListR = error "not implemented" diff --git a/src/Handler/Workflow/Definition/New.hs b/src/Handler/Workflow/Definition/New.hs new file mode 100644 index 000000000..e99501824 --- /dev/null +++ b/src/Handler/Workflow/Definition/New.hs @@ -0,0 +1,9 @@ +module Handler.Workflow.Definition.New + ( getAdminWorkflowDefinitionNewR, postAdminWorkflowDefinitionNewR + ) where + +import Import + +getAdminWorkflowDefinitionNewR, postAdminWorkflowDefinitionNewR :: Handler Html +getAdminWorkflowDefinitionNewR = postAdminWorkflowDefinitionNewR +postAdminWorkflowDefinitionNewR = error "not implemented" diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 08783669c..18e3e6b38 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -54,3 +54,9 @@ type InstanceId = UUID type ClusterId = UUID type TokenId = UUID type TermCandidateIncidence = UUID + +type SessionFileReference = Digest SHA3_256 + +type WorkflowDefinitionName = CI Text +type WorkflowInstanceName = CI Text +type WorkflowInstanceCategory = CI Text diff --git a/src/Model/Types/TH/JSON.hs b/src/Model/Types/TH/JSON.hs index c63aa30db..1a13635d6 100644 --- a/src/Model/Types/TH/JSON.hs +++ b/src/Model/Types/TH/JSON.hs @@ -69,7 +69,7 @@ predNFAesonOptions = defaultOptions } -workflowGraphAesonOptions, workflowGraphEdgeAesonOptions, workflowGraphNodeAesonOptions, workflowActionAesonOptions :: Options +workflowGraphAesonOptions, workflowGraphEdgeAesonOptions, workflowGraphNodeAesonOptions, workflowActionAesonOptions, workflowPayloadViewAesonOptions :: Options workflowGraphAesonOptions = defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } @@ -84,3 +84,6 @@ workflowGraphNodeAesonOptions = defaultOptions workflowActionAesonOptions = defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } +workflowPayloadViewAesonOptions = defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index 591066acf..f95d59d8d 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -28,8 +28,8 @@ import Type.Reflection (eqTypeRep, typeOf, (:~~:)(..)) ----- WORKFLOW GRAPH ----- data WorkflowGraph fileid userid = WorkflowGraph - { wgNodes :: Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid) - , wgPayloadViewers :: Map WorkflowPayloadLabel (NonNull (Set (WorkflowRole userid))) + { wgNodes :: Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid) + , wgPayloadView :: Map WorkflowPayloadLabel (WorkflowPayloadView userid) } deriving (Eq, Ord, Show, Generic, Typeable) @@ -44,9 +44,8 @@ newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLab deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql) data WorkflowGraphNode fileid userid = WGN - { wgnDisplayLabel :: Maybe Text - , wgnInitial :: Bool - , wgnFinished :: Bool + { wgnDisplayLabel :: Maybe I18nText + , wgnInitial, wgnFinished :: Bool , wgnViewers :: Set (WorkflowRole userid) , wgnEdges :: Map WorkflowGraphEdgeLabel (WorkflowGraphEdge fileid userid) } @@ -85,39 +84,44 @@ data WorkflowRole userid ----- WORKFLOW GRAPH: PAYLOAD SPECIFICATION ----- +data WorkflowPayloadView userid = WorkflowPayloadView + { wpvViewers :: NonNull (Set (WorkflowRole userid)) + , wpvDisplayLabel :: I18nText + } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) + data WorkflowPayloadSpec fileid userid = forall payload. Typeable payload => WorkflowPayloadSpec (WorkflowPayloadField fileid userid payload) deriving (Typeable) deriving instance (Show fileid, Show userid) => Show (WorkflowPayloadSpec fileid userid) data WorkflowPayloadField fileid userid (payload :: Type) where - WorkflowPayloadFieldText :: { wpftLabel :: Text - , wpftPlaceholder :: Maybe Text - , wpftTooltip :: Maybe Text + WorkflowPayloadFieldText :: { wpftLabel :: I18nText + , wpftPlaceholder :: Maybe I18nText + , wpftTooltip :: Maybe I18nHtml , wpftDefault :: Maybe Text , wpftOptional :: Bool } -> WorkflowPayloadField fileid userid Text - WorkflowPayloadFieldNumber :: { wpfnLabel :: Text - , wpfnPlaceholder :: Maybe Text - , wpfnTooltip :: Maybe Text + WorkflowPayloadFieldNumber :: { wpfnLabel :: I18nText + , wpfnPlaceholder :: Maybe I18nText + , wpfnTooltip :: Maybe I18nHtml , wpfnDefault , wpfnMin , wpfnMax , wpfnStep :: Maybe Scientific , wpfnOptional :: Bool } -> WorkflowPayloadField fileid userid Scientific - WorkflowPayloadFieldBool :: { wpfbLabel :: Text - , wpfbTooltip :: Maybe Text + WorkflowPayloadFieldBool :: { wpfbLabel :: I18nText + , wpfbTooltip :: Maybe I18nHtml , wpfbDefault :: Maybe Bool , wpfbOptional :: Maybe Text -- ^ Optional if `Just`; encodes label of `Nothing`-Option } -> WorkflowPayloadField fileid userid Bool - WorkflowPayloadFieldFile :: { wpffLabel :: Text - , wpffTooltip :: Maybe Text + WorkflowPayloadFieldFile :: { wpffLabel :: I18nText + , wpffTooltip :: Maybe I18nHtml , wpffDefault :: Maybe fileid , wpffOptional :: Bool } -> WorkflowPayloadField fileid userid FileInfo - WorkflowPayloadFieldUser :: { wpfuLabel :: Text - , wpfuTooltip :: Maybe Text + WorkflowPayloadFieldUser :: { wpfuLabel :: I18nText + , wpfuTooltip :: Maybe I18nHtml , wpfuDefault :: Maybe userid , wpfuOptional :: Bool } -> WorkflowPayloadField fileid userid userid @@ -164,11 +168,12 @@ data WorkflowInstanceScope termid schoolid courseid = WISGlobal | WISTerm { wisTerm :: termid } | WISSchool { wisSchool :: schoolid } + | WISTermSchool { wisTerm :: termid, wisSchool :: schoolid } | WISCourse { wisCourse :: courseid } deriving (Eq, Ord, Show, Read, Data, Generic, Typeable) data WorkflowInstanceScope' - = WISGlobal' | WISTerm' | WISSchool' | WISCourse' + = WISGlobal' | WISTerm' | WISSchool' | WISTermSchool' | WISCourse' deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable) deriving anyclass (Universe, Finite) @@ -236,6 +241,12 @@ data WorkflowFieldPayload'' = WFPText' | WFPNumber' | WFPBool' | WFPFile' | WFPU deriving anyclass (Universe, Finite) +----- PathPiece instances ----- + +nullaryPathPiece ''WorkflowInstanceScope' $ camelToPathPiece' 1 +nullaryPathPiece ''WorkflowFieldPayload'' $ camelToPathPiece' 1 . fromJust . stripSuffix "'" + + ----- ToJSON / FromJSON instances ----- omitNothing :: [JSON.Pair] -> [JSON.Pair] @@ -246,6 +257,11 @@ deriveJSON defaultOptions , constructorTagModifier = camelToPathPiece' 2 } ''WorkflowRole +deriveToJSON workflowPayloadViewAesonOptions ''WorkflowPayloadView + +instance (FromJSON userid, Ord userid) => FromJSON (WorkflowPayloadView userid) where + parseJSON = genericParseJSON workflowPayloadViewAesonOptions + instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowGraph fileid userid) where toJSON = genericToJSON workflowGraphAesonOptions instance ( FromJSON fileid, FromJSON userid @@ -367,9 +383,7 @@ deriveJSON defaultOptions , fieldLabelModifier = camelToPathPiece' 1 } ''WorkflowInstanceScope -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 . fromJust . stripSuffix "'" - } ''WorkflowInstanceScope' +pathPieceJSON ''WorkflowInstanceScope' deriveToJSON workflowActionAesonOptions ''WorkflowAction diff --git a/src/Utils.hs b/src/Utils.hs index 87d8f3586..89c7a99ec 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -31,6 +31,7 @@ import Utils.Cookies as Utils import Utils.Cookies.Registered as Utils import Utils.Session as Utils import Utils.Csv as Utils +import Utils.I18n as Utils import Text.Blaze (Markup, ToMarkup) diff --git a/src/Utils/I18n.hs b/src/Utils/I18n.hs new file mode 100644 index 000000000..253573459 --- /dev/null +++ b/src/Utils/I18n.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Utils.I18n + ( I18n(..) + , I18nText, I18nHtml + , renderMessageI18n + , i18nMessageFor + , Element + ) where + +import ClassyPrelude.Yesod hiding (derivePersistFieldJSON) + +import qualified Data.Aeson as JSON +import qualified Data.HashMap.Lazy as HashMap + +import qualified Data.Map as Map + +import Model.Types.TH.JSON + +import Data.Data (Data) + + +data I18n a = I18n + { i18nFallback :: a + , i18nTranslations :: Map Lang a + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data, Generic, Typeable) + deriving anyclass (MonoFunctor, MonoFoldable, MonoTraversable) +type instance Element (I18n a) = a + +type I18nText = I18n Text +type I18nHtml = I18n Html + + +instance MonoPointed (I18n a) where + opoint = flip I18n Map.empty + +instance IsString a => IsString (I18n a) where + fromString = opoint . fromString + +instance ToJSON a => ToJSON (I18n a) where + toJSON I18n{..} + | Map.null i18nTranslations + , fallbackUnambiguous + = toJSON i18nFallback + | Map.null i18nTranslations + = JSON.object [ "fallback" JSON..= i18nFallback ] + | otherwise + = JSON.object [ "fallback" JSON..= i18nFallback + , "translations" JSON..= i18nTranslations + ] + where + fallbackUnambiguous = case toJSON i18nFallback of + JSON.Object hm -> not $ HashMap.member "fallback" hm + _other -> True + +instance FromJSON a => FromJSON (I18n a) where + parseJSON (JSON.Object o) + | HashMap.member "fallback" o = do + i18nFallback <- o JSON..: "fallback" + i18nTranslations <- o JSON..:? "translations" JSON..!= Map.empty + return I18n{..} + parseJSON val = do + i18nFallback <- JSON.parseJSON val + let i18nTranslations = Map.empty + return I18n{..} + +derivePersistFieldJSON ''I18n + + +renderMessageI18n :: RenderMessage site msg + => [Lang] -> site -> msg -> I18nText +renderMessageI18n ls app msg = I18n + { i18nFallback = renderMessage app ls msg + , i18nTranslations = Map.fromList . flip map ls $ \l -> (l, ) $ renderMessage app (l : filter (/= l) ls) msg + } + +i18nMessageFor :: ( MonadHandler m + , RenderMessage (HandlerSite m) msg + ) + => [Lang] -> msg -> m I18nText +i18nMessageFor ls msg = getsYesod $ flip (renderMessageI18n ls) msg