fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(legal): redirect legal to external fraport urls

Browse Source
This commit is contained in:
Steffen Jost 2022-11-11 17:11:39 +01:00
parent 00dc0be032
commit 0d9c2963d5
10 changed files with 138 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
config/settings.yml
View File

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

1
messages/uniworx/categories/info/de-de-formal.msg
View File

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

1
messages/uniworx/categories/info/en-eu.msg
View File

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

1
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

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

1
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

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

5
routes
View File

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

2
src/Application.hs
View File

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

96
src/Foundation/Navigation.hs
View File

@ -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 InfoLecturerR = i18nCrumb MsgInfoLecturerTitle $ Just InfoR
breadcrumb LegalR = i18nCrumb MsgMenuLegal $ Just InfoR
breadcrumb InfoR = i18nCrumb MsgMenuInformation Nothing
breadcrumb InfoLecturerR = i18nCrumb MsgInfoLecturerTitle $ 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 FaqR = i18nCrumb MsgBreadcrumbFaq $ Just InfoR
breadcrumb VersionR = i18nCrumb MsgMenuVersion $ 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
guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh
breadcrumb (QualificationSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs
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
guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh
breadcrumb (LmsSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs
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
[ NavPageActionPrimary
pageActions (LmsR sid qsh) = return
[ NavPageActionPrimary
{ navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh
, navChildren =
[ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh
, navChildren =
[ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh
]
}
, NavPageActionPrimary
, NavPageActionPrimary
{ navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh
, navChildren =
[ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh
, defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh
, navChildren =
[ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh
, defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh
]
}
, NavPageActionPrimary
, NavPageActionPrimary
{ navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh
, navChildren =
[ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh
, defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh
, navChildren =
[ defNavLink MsgMenuLmsUpload $ LmsResultUploadR 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 []

43
src/Handler/Info.hs
View File

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

23
src/Settings.hs
View File

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