feat(workflows): definition route stubs & i18n

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
+SystemFaculty: Fakultätsmitglied
+
+WorkflowInstanceScopeKindGlobal: Systemweit
+WorkflowInstanceScopeKindTerm: Pro Semester
+WorkflowInstanceScopeKindSchool: Pro Institut
+WorkflowInstanceScopeKindTermSchool: Pro Institut & Semester
+WorkflowInstanceScopeKindCourse: Pro Veranstaltung

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

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

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

src/CryptoID.hs

@@ -73,6 +73,7 @@ decCryptoIDs [ ''SubmissionId
              , ''CourseEventId
              , ''TutorialId
              , ''ExternalExamId
+             , ''WorkflowWorkflowId
              ]
 
 decCryptoIDKeySize

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
 

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

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

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

src/Handler/Workflow.hs

@@ -0,0 +1,5 @@
+module Handler.Workflow
+  ( module Handler.Workflow
+  ) where
+
+import Handler.Workflow.Definition as Handler.Workflow

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

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"

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"

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"

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"

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"

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

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
+  }

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
 

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)
 

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