chore(legal): redirect legal to external fraport urls

config/settings.yml

@@ -32,6 +32,18 @@ mail-support:
   email:        "_env:MAILSUPPORT:uni2work@ifi.lmu.de"
 mail-retain-sent: 31470547
 
+legal-external:
+  - language:         "en"
+    imprint:          "https://www.fraport.com/en/tools/imprint.html"
+    data-protection:  "https://www.fraport.com/en/our-group/data-protection-statement.html"
+    terms-of-use:     "https://www.fraport.com/en/tools/legal-information.html"
+    payments:         "https://www.fraport.com/de/geschaeftsfelder/service/geschaeftspartner/richtlinien-und-zahlungsbedingungen.html"
+  - language:         "de"
+    imprint:          "https://www.fraport.com/de/tools/impressum.html"
+    data-protection:  "https://www.fraport.com/de/konzern/datenschutz.html"
+    terms-of-use:     "https://www.fraport.com/de/tools/disclaimer.html"
+    payments:         "https://www.fraport.com/de/geschaeftsfelder/service/geschaeftspartner/richtlinien-und-zahlungsbedingungen.html"  
+
 job-workers:        "_env:JOB_WORKERS:10"
 job-flush-interval: "_env:JOB_FLUSH:30"
 job-cron-interval:  "_env:CRON_INTERVAL:60"

messages/uniworx/categories/info/de-de-formal.msg

@@ -3,6 +3,7 @@
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
 HeadingLegal: Rechtliche Informationen
+InfoSupervisorTitle: Hinweise für Ansprechpartner
 InfoLecturerTitle: Hinweise für Veranstalter:innen
 InfoLecturerCourses: Veranstaltungen
 InfoLecturerExercises: Übungsbetrieb

messages/uniworx/categories/info/en-eu.msg

@@ -3,6 +3,7 @@
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
 HeadingLegal: Legal
+InfoSupervisorTitle: Information for Supervisors
 InfoLecturerTitle: Information for lecturers
 InfoLecturerCourses: Courses
 InfoLecturerExercises: Course Exercises

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -21,6 +21,7 @@ MenuDataProt: Datenschutzerklärung
 MenuTermsUse: Nutzungsbedingungen
 MenuCopyright: Urheberrecht
 MenuImprint: Impressum
+MenuPayments: Zahlungsbedingungen
 
 MenuInstance: Instanz-Identifikation
 MenuHealth: Instanz-Zustand

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -21,6 +21,7 @@ MenuDataProt: Data protection
 MenuTermsUse: Terms of use
 MenuCopyright: Copyright
 MenuImprint: Imprint
+MenuPayments: Payment Terms
 
 MenuInstance: Instance identification
 MenuHealth: Instance health

routes

@@ -78,10 +78,15 @@
 /instance                     InstanceR        GET              !free
 /info                         InfoR            GET              !free
 /info/lecturer                InfoLecturerR    GET              !free
+/info/supervisor              InfoSupervisorR  GET              !free
 /info/legal                   LegalR           GET              !free
 /info/allocation              InfoAllocationR  GET              !free
 /info/glossary                GlossaryR        GET              !free
 /info/faq                     FaqR             GET              !free
+/info/terms-of-use            TermsOfUseR      GET              !free
+/info/payments                PaymentsR        GET              !free
+/imprint                      ImprintR         GET              !free
+/data-protection              DataProtectionR  GET              !free
 /version                      VersionR         GET              !free
 /status                       StatusR          GET              !free
 

src/Application.hs

@@ -370,6 +370,8 @@ makeFoundation appSettings''@AppSettings{..} = do
                           }
           return . Just $ mkAvsQuery avsServer avsAuth avsEnv
 
+      when (null appLegalExternal) $ $logErrorS "Legal" "Configuration of external legal links is missing."
+
       $logDebugS "Runtime configuration" $ tshowCrop appSettings'
 
       let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery

src/Foundation/Navigation.hs

@@ -47,7 +47,7 @@ import Yesod.Core.Types (HandlerContents)
 
 
 type Breadcrumb = (Text, Maybe (Route UniWorX))
-  
+
 -- Define breadcrumbs.
 i18nCrumb :: forall msg m.
              (RenderMessage UniWorX msg, MonadHandler m, HandlerSite m ~ UniWorX)
@@ -117,7 +117,7 @@ breadcrumb AdminLdapR       = i18nCrumb MsgMenuLdap             $ Just AdminR
 
 breadcrumb PrintCenterR     = i18nCrumb MsgMenuApc              Nothing
 breadcrumb PrintSendR       = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR
-breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload  $ Just PrintCenterR           
+breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload  $ Just PrintCenterR
 breadcrumb PrintAckR{}      = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR -- never displayed
 breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR -- never displayed
 
@@ -134,12 +134,18 @@ breadcrumb (ExamOfficeR EOFieldsR) = i18nCrumb MsgMenuExamOfficeFields . Just $
 breadcrumb (ExamOfficeR EOUsersR)  = i18nCrumb MsgMenuExamOfficeUsers . Just $ ExamOfficeR EOExamsR
 breadcrumb (ExamOfficeR EOUsersInviteR) = i18nCrumb MsgBreadcrumbExamOfficeUserInvite Nothing
 
-breadcrumb InfoR            = i18nCrumb MsgMenuInformation     Nothing
+breadcrumb InfoR            = i18nCrumb MsgMenuInformation            Nothing
-breadcrumb InfoLecturerR    = i18nCrumb MsgInfoLecturerTitle $ Just InfoR
+breadcrumb InfoLecturerR    = i18nCrumb MsgInfoLecturerTitle        $ Just InfoR
-breadcrumb LegalR           = i18nCrumb MsgMenuLegal         $ Just InfoR
+breadcrumb InfoSupervisorR  = i18nCrumb MsgInfoSupervisorTitle      $ Just InfoR
+breadcrumb LegalR           = i18nCrumb MsgMenuLegal                $ Just InfoR
+breadcrumb ImprintR         = i18nCrumb MsgMenuImprint              $ Just LegalR
+breadcrumb DataProtectionR  = i18nCrumb MsgMenuDataProt             $ Just LegalR
+breadcrumb TermsOfUseR      = i18nCrumb MsgMenuTermsUse             $ Just LegalR
+breadcrumb PaymentsR        = i18nCrumb MsgMenuPayments             $ Just LegalR
+
 breadcrumb InfoAllocationR  = i18nCrumb MsgBreadcrumbAllocationInfo $ Just InfoR
-breadcrumb VersionR         = i18nCrumb MsgMenuVersion       $ Just InfoR
+breadcrumb VersionR         = i18nCrumb MsgMenuVersion              $ Just InfoR
-breadcrumb FaqR             = i18nCrumb MsgBreadcrumbFaq     $ Just InfoR
+breadcrumb FaqR             = i18nCrumb MsgBreadcrumbFaq            $ Just InfoR
 
 
 breadcrumb HelpR            = i18nCrumb MsgMenuHelp            Nothing
@@ -150,21 +156,21 @@ breadcrumb InstanceR        = i18nCrumb MsgMenuInstance        Nothing
 breadcrumb StatusR          = i18nCrumb MsgMenuHealth          Nothing  -- never displayed
 
 breadcrumb  QualificationAllR                       = i18nCrumb MsgMenuQualifications Nothing
-breadcrumb (QualificationSchoolR          ssh     ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs  
+breadcrumb (QualificationSchoolR          ssh     ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs
-  guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh 
+  guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh
   return (CI.original $ unSchoolKey ssh, Just QualificationAllR)
 breadcrumb (QualificationR                ssh  qsh) =useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ QualificationSchoolR ssh) $ do
-  guardM . lift . existsBy $ SchoolQualificationShort ssh qsh 
+  guardM . lift . existsBy $ SchoolQualificationShort ssh qsh
   return (CI.original qsh, Just $ QualificationSchoolR ssh)
 
 breadcrumb  LmsAllR                       = i18nCrumb MsgMenuLms Nothing
-breadcrumb (LmsSchoolR          ssh     ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs  
+breadcrumb (LmsSchoolR          ssh     ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs
-  guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh 
+  guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh
   return (CI.original $ unSchoolKey ssh, Just LmsAllR)
 breadcrumb (LmsR                ssh  qsh) =useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ LmsSchoolR ssh) $ do
-  guardM . lift . existsBy $ SchoolQualificationShort ssh qsh 
+  guardM . lift . existsBy $ SchoolQualificationShort ssh qsh
   return (CI.original qsh, Just $ LmsSchoolR ssh)
-breadcrumb (LmsEditR            ssh  qsh) = i18nCrumb MsgMenuLmsEdit       $ Just $ LmsR          ssh qsh 
+breadcrumb (LmsEditR            ssh  qsh) = i18nCrumb MsgMenuLmsEdit       $ Just $ LmsR          ssh qsh
 breadcrumb (LmsUsersR           ssh  qsh) = i18nCrumb MsgMenuLmsUsers      $ Just $ LmsR          ssh qsh
 breadcrumb (LmsUsersDirectR     ssh  qsh) = i18nCrumb MsgMenuLmsUsers      $ Just $ LmsUsersR     ssh qsh -- never displayed, TypedContent
 breadcrumb (LmsUserlistR        ssh  qsh) = i18nCrumb MsgMenuLmsUserlist   $ Just $ LmsR          ssh qsh
@@ -541,7 +547,7 @@ navLinkAccess NavLink{..} = case navAccess' of
       authCtx <- getAuthContext
       memcachedBy (Just . Right $ 2 * diffMinute) (NavCacheRouteAccess authCtx nt route) . useRunDB $
         bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route
-  
+
 defaultLinks :: ( MonadHandler m
                 , HandlerSite m ~ UniWorX
              -- , MonadThrow m
@@ -627,17 +633,17 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
         }
   , return $ NavFooter NavLink
       { navLabel       = MsgMenuDataProt
-      , navRoute       = LegalR :#: ("data-protection" :: Text)
+      , navRoute       = DataProtectionR
       , navAccess'     = NavAccessTrue
-      , navType        = NavTypeLink { navModal = False }
+      , navType        = NavTypeLink { navModal = True }
       , navQuick'      = mempty
       , navForceActive = False
       }
   , return $ NavFooter NavLink
       { navLabel       = MsgMenuTermsUse
-      , navRoute       = LegalR :#: ("terms-of-use" :: Text)
+      , navRoute       = TermsOfUseR
       , navAccess'     = NavAccessTrue
-      , navType        = NavTypeLink { navModal = False }
+      , navType        = NavTypeLink { navModal = True }
       , navQuick'      = mempty
       , navForceActive = False
       }
@@ -651,9 +657,9 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
       }
   , return $ NavFooter NavLink
       { navLabel       = MsgMenuImprint
-      , navRoute       = LegalR :#: ("imprint" :: Text)
+      , navRoute       = ImprintR
       , navAccess'     = NavAccessTrue
-      , navType        = NavTypeLink { navModal = False }
+      , navType        = NavTypeLink { navModal = True }
       , navQuick'      = mempty
       , navForceActive = False
       }
@@ -760,7 +766,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
         , navQuick'      = mempty
         , navForceActive = False
         }
-      }    
+      }
   , return NavHeaderContainer
       { navHeaderRole = NavHeaderPrimary
       , navLabel      = SomeMessage MsgMenuAdminHeading
@@ -837,7 +843,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
               , navType        = NavTypeLink { navModal = False }
               , navQuick'      = mempty
               , navForceActive = False
-              }    
+              }
           ]
       }
   , return NavHeaderContainer
@@ -2019,7 +2025,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do
       { navLink = NavLink
         { navLabel       = MsgMenuSheetPersonalisedFiles
         , navRoute       = CSheetR tid ssh csh shn SPersonalFilesR
-        , navAccess'     = NavAccessDB $ 
+        , navAccess'     = NavAccessDB $
             let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectMaybe . E.from $ \(sheet `E.InnerJoin` course) -> do
                   E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
                   E.where_$ sheet E.^. SheetName E.==. E.val shn
@@ -2078,7 +2084,7 @@ pageActions (CSheetR tid ssh csh shn SSubsR) = return
     { navLink = NavLink
       { navLabel       = MsgMenuSubmissionNew
       , navRoute       = CSheetR tid ssh csh shn SubmissionNewR
-      , navAccess' = NavAccessDB $ 
+      , navAccess' = NavAccessDB $
           let submissionAccess = hasWriteAccessTo $ CSheetR tid ssh csh shn SSubsR
               hasNoSubmission = maybeT (return False) $ do
                 uid <- MaybeT $ liftHandler maybeAuthId
@@ -2479,31 +2485,31 @@ pageActions ParticipantsListR = return
     , navChildren = []
     }
   ]
-pageActions (LmsR sid qsh) = return 
+pageActions (LmsR sid qsh) = return
-  [ NavPageActionPrimary 
+  [ NavPageActionPrimary
     { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh
-    , navChildren = 
+    , navChildren =
-        [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh 
+        [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh
         ]
     }
-  , NavPageActionPrimary 
+  , NavPageActionPrimary
     { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh
-    , navChildren = 
+    , navChildren =
-        [ defNavLink MsgMenuLmsUpload       $ LmsUserlistUploadR sid qsh        
+        [ defNavLink MsgMenuLmsUpload       $ LmsUserlistUploadR sid qsh
-        , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh        
+        , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh
         ]
     }
-  , NavPageActionPrimary 
+  , NavPageActionPrimary
     { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh
-    , navChildren = 
+    , navChildren =
-        [ defNavLink MsgMenuLmsUpload       $ LmsResultUploadR sid qsh        
+        [ defNavLink MsgMenuLmsUpload       $ LmsResultUploadR sid qsh
-        , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh        
+        , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh
         ]
     }
-  , NavPageActionSecondary { 
+  , NavPageActionSecondary {
       navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh
     }
-  , NavPageActionSecondary { 
+  , NavPageActionSecondary {
       navLink = defNavLink MsgMenuLmsFake $ LmsFakeR sid qsh
     }
   ]
@@ -2521,14 +2527,14 @@ pageActions ApiDocsR = return
     }
   ]
 pageActions PrintCenterR = do
-  openDays <- useRunDB $ Ex.select $ do    
+  openDays <- useRunDB $ Ex.select $ do
     pj <- Ex.from $ Ex.table @PrintJob
-    let pjDay = E.day $ pj Ex.^. PrintJobCreated 
+    let pjDay = E.day $ pj Ex.^. PrintJobCreated
     Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
     Ex.orderBy [ Ex.asc pjDay ]
     pure (pjDay, pj Ex.^. PrintJobId)
-  
+
-  let dayMap = Map.fromListWith (<>) (openDays <&> (\(Ex.unValue -> pjDay, Ex.unValue -> pjId) -> (pjDay, Set.singleton pjId)))  
+  let dayMap = Map.fromListWith (<>) (openDays <&> (\(Ex.unValue -> pjDay, Ex.unValue -> pjId) -> (pjDay, Set.singleton pjId)))
       toDayAck (d, pjIds) = do
         dtxt <- formatTime SelFormatDate d
         let n = Set.size pjIds
@@ -2536,7 +2542,7 @@ pageActions PrintCenterR = do
             msg = "#" <> tshow n <> ", " <> dtxt
         return     NavPageActionPrimary
                     { navLink = NavLink
-                      { navLabel       = SomeMessage msg 
+                      { navLabel       = SomeMessage msg
                       , navRoute       = PrintAckR d n h
                       , navAccess'     = NavAccessTrue
                       , navType        = NavTypeLink { navModal = True }
@@ -2556,7 +2562,7 @@ pageActions PrintCenterR = do
                       }
                     }
   dayLinks <- mapM toDayAck $ Map.toAscList dayMap
-  return $ manualSend : take 9 dayLinks  
+  return $ manualSend : take 9 dayLinks
 
 pageActions _ = return []
 

src/Handler/Info.hs

@@ -20,9 +20,25 @@ import Development.GitRev
 
 import Auth.LDAP (ADError(..), ADInvalidCredentials(..), CampusMessage(..))
 
-import Yesod.Auth.Message(AuthMessage(..))
+import Yesod.Auth.Message(AuthMessage(..)) 
-  
 
+
+pickLegalExternalLang :: Handler LegalExternal
+pickLegalExternalLang = do 
+    langMap <- $cachedHereBinary ("legal_external"::Text) makeMapLegalExternal
+    availLangs <- case nonEmpty' (Map.keys langMap) of 
+      Just ls -> pure ls
+      Nothing -> $logErrorS "Legal" "Configuration of external legal links is missing." >> notFound
+    lang <- selectLanguage availLangs
+    return $ langMap ! lang   
+  where 
+    makeMapLegalExternal :: Handler (Map Lang LegalExternal)
+    makeMapLegalExternal = do 
+      legExs <- getsYesod $ view _appLegalExternal
+      return $ Set.foldl' (\acc le -> Map.singleton (externalLanguage le) le <> acc) mempty legExs
+      -- return $ Map.fromAscList [(externalLanguage le,le) | le <- Set.toAscList legExs]
+
+ 
 -- | Versionsgeschichte
 getVersionR :: Handler TypedContent
 getVersionR = selectRep $ do
@@ -31,6 +47,29 @@ getVersionR = selectRep $ do
   provideRep getInfoR
 
 
+getImprintR :: Handler Html 
+getImprintR = do
+  le <- pickLegalExternalLang
+  redirect $ externalImprint le
+
+getDataProtectionR :: Handler Html
+getDataProtectionR = do
+  le <- pickLegalExternalLang
+  redirect $ externalDataProtection le
+
+getPaymentsR :: Handler Html
+getPaymentsR = do
+  le <- pickLegalExternalLang
+  redirect $ externalPayments le
+  
+getTermsOfUseR :: Handler Html
+getTermsOfUseR = do 
+  le <- pickLegalExternalLang
+  redirect $ externalTermsOfUse le
+
+getInfoSupervisorR :: Handler Html
+getInfoSupervisorR = error "TODO"
+
 -- | Datenschutzerklaerung und Aufbewahrungspflichten, Nutzungsbedingungen, Urheberrecht, Impressum
 getLegalR :: Handler Html
 getLegalR =

src/Settings.hs

@@ -246,6 +246,8 @@ data AppSettings = AppSettings
     , appCommunicationAttachmentsMaxSize :: Maybe Natural
     
     , appFileChunkingParams     :: FastCDCParameters
+
+    , appLegalExternal          :: Set LegalExternal
     
     } deriving Show
 
@@ -412,6 +414,17 @@ data SettingBotMitigation
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
   deriving anyclass (Universe, Finite)
 
+data LegalExternal = LegalExternal
+  { externalLanguage :: Lang 
+  , externalImprint :: Text
+  , externalDataProtection :: Text
+  , externalTermsOfUse :: Text
+  , externalPayments :: Text    
+  }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+makeLenses_ ''LegalExternal
+
+
 nullaryPathPiece ''ApprootScope $ camelToPathPiece' 1
 pathPieceJSON ''ApprootScope
 pathPieceJSONKey ''ApprootScope
@@ -585,6 +598,14 @@ instance FromJSON ServerSessionSettings where
       , ServerSession.setPersistentCookies <$> persistentCookies
       ])
 
+instance FromJSON LegalExternal where 
+  parseJSON = withObject "LegalExternal" $ \o -> do
+    externalLanguage <- o .: "language"
+    externalImprint <- o .: "imprint"
+    externalDataProtection <- o .: "data-protection"
+    externalTermsOfUse<- o .: "terms-of-use"
+    externalPayments <- o .: "payments"
+    return LegalExternal{..}
 
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
@@ -779,6 +800,8 @@ instance FromJSON AppSettings where
 
         appCommunicationAttachmentsMaxSize <- o .:? "communication-attachments-max-size"
 
+        appLegalExternal <- o .: "legal-external"
+
         return AppSettings{..}
       where isValidARCConf ARCConf{..} = arccMaximumWeight > 0