From ebb81e0c54f9a8d3b6d27ce9d650d50b8bd8bcd2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 24 Apr 2023 16:42:57 +0000 Subject: [PATCH 01/29] refactor(avs): avs queries are automatically chunked --- src/Model/Types/Avs.hs | 6 ++++ src/Utils/Avs.hs | 68 +++++++++++++++++++----------------------- 2 files changed, 36 insertions(+), 38 deletions(-) diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index bd9aaa0e9..a12980ed6 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -197,6 +197,7 @@ discernAvsCardPersonalNo _ = Nothing newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int deriving (Eq, Ord, Generic) deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable, Binary) +-- TODO: consider using "makeWrapped ''AvsPersonId" instance E.SqlString AvsPersonId -- As opposed to AvsObjPersonId, AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API; instance FromJSON AvsPersonId where @@ -590,6 +591,7 @@ deriveJSON defaultOptions type AvsResponseStatus :: Type newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson) deriving (Eq, Ord, Show, Generic) +makeWrapped ''AvsResponseStatus deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -601,6 +603,7 @@ instance Semigroup AvsResponseStatus where newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson) deriving (Eq, Ord, Show, Generic) +-- makeWrapped ''AvsResponsePerson deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -610,6 +613,7 @@ deriveJSON defaultOptions newtype AvsResponseContact = AvsResponseContact (Set AvsDataContact) deriving (Eq, Ord, Show, Generic) +makeWrapped ''AvsResponseContact deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -666,10 +670,12 @@ deriveJSON defaultOptions newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId) deriving (Eq, Ord, Show, Generic) deriveJSON defaultOptions ''AvsQueryStatus +makeWrapped ''AvsQueryStatus newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object deriving (Eq, Ord, Show, Generic) deriveJSON defaultOptions ''AvsQueryContact +makeWrapped ''AvsQueryContact newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently deriving (Eq, Ord, Show, Generic) diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 00580b26a..abe528279 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -13,10 +13,10 @@ import qualified Data.Text as Text import Servant import Servant.Client -#ifdef DEVELOPMENT -#else +-- #ifdef DEVELOPMENT +-- #else import Servant.Client.Core (requestPath) -#endif +-- #endif import Model.Types.Avs @@ -34,8 +34,8 @@ type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQueryS avsMaxSetLicenceAtOnce :: Int avsMaxSetLicenceAtOnce = 90 -- maximum input set size for avsQuerySetLicences as enforced by AVS -avsMaxGetStatusAtOnce :: Int -avsMaxGetStatusAtOnce = 900 -- maximum input set size for avsQueryStatus as enforced by AVS +avsMaxQueryAtOnce :: Int +avsMaxQueryAtOnce = 900 -- maximum input set size for avsQueryStatus as enforced by AVS avsApi :: Proxy AVS @@ -68,20 +68,20 @@ avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery -#ifdef DEVELOPMENT -mkAvsQuery _ _ _ = AvsQuery - { avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty - , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty - , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing) - , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty - , avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty - } -#else +-- #ifdef DEVELOPMENT +-- mkAvsQuery _ _ _ = AvsQuery +-- { avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty +-- , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty +-- , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing) +-- , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty +-- , avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty +-- } +-- #else mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery - { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv - , avsQueryStatus = \q -> liftIO $ runClientM (splitQueryStatus q) cliEnv - , avsQueryContact = \q -> liftIO $ runClientM (rawQueryContact q) cliEnv - , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv + { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv + , avsQueryStatus = \q -> liftIO $ runClientM (splitQuery rawQueryStatus q) cliEnv + , avsQueryContact = \q -> liftIO $ runClientM (splitQuery rawQueryContact q) cliEnv + , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv -- TODO: currently uses setLicencesAvs for splitting to ensure return of correctly set licences -- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv , avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv } @@ -96,26 +96,18 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database! catch404toEmpty other = other - -- TODO: make a generic implementation for this - splitQueryStatus :: AvsQueryStatus -> ClientM AvsResponseStatus - splitQueryStatus q@(AvsQueryStatus avids) - | Set.size avids <= avsMaxGetStatusAtOnce = rawQueryStatus q - | otherwise = do - let (avid_1,avid_2) = Set.splitAt avsMaxGetStatusAtOnce avids - res1 <- rawQueryStatus (AvsQueryStatus avid_1) - res2 <- splitQueryStatus (AvsQueryStatus avid_2) - return $ res1 <> res2 - - -- splitQuery :: (a -> Set b) -> (Set b -> a) -> (a -> ClientM c) -> a -> ClientM c - -- splitQuery toSet fromSet rawQuery q - -- | Set.size (toSet q) <= avsMaxGetStatusAtOnce = rawQueryStatus q - -- | otherwise = do - -- let (fromSet -> avid_1,fromSet -> avid_2) = Set.splitAt avsMaxGetStatusAtOnce (toSet q) - -- res1 <- rawQuery avid_1 - -- res2 <- splitQuery toSet fromSet rawQuery avid_2 - -- return $ fromSet (toSet res1 <> toSet res2) - -#endif + splitQuery :: (Wrapped a, Wrapped c, Unwrapped a ~ Set b, Semigroup (Unwrapped c)) + => (a -> ClientM c) -> a -> ClientM c + splitQuery rawQuery q + | Set.size s <= avsMaxQueryAtOnce = rawQuery q + | otherwise = do + let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s + res1 <- rawQuery $ view _Unwrapped' avsid1 + res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2 + return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped') + where + s = view _Wrapped' q +-- #endif ----------------------- -- Utility Functions -- From 76fb44d898f684396fd98fe55ff8e64a7980b704 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 25 Apr 2023 09:48:45 +0000 Subject: [PATCH 02/29] chore(users): keep filters after table action --- src/Handler/Users.hs | 18 +++++++++--------- src/Handler/Utils.hs | 19 +++++++++++++++++++ src/Handler/Utils/Table/Pagination.hs | 2 +- src/Utils/Form.hs | 3 ++- templates/widgets/form/form.hamlet | 2 +- 5 files changed, 32 insertions(+), 12 deletions(-) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 2c68d028a..3ae8c8885 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -334,7 +334,7 @@ postUsersR = do , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } , dbtParams = DBParamsForm { dbParamsFormMethod = POST - , dbParamsFormAction = Just $ SomeRoute UsersR + , dbParamsFormAction = Nothing -- Just $ SomeRoute (UsersR, [("users-user-company","fraport")]) , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional @@ -351,21 +351,21 @@ postUsersR = do , dbtExtraReps = [] } + $logInfoS "UsersFormResult" $ tshow usersRes formResult usersRes $ \case (act, usersSet) - | Set.null usersSet && isNotSetSupervisor act -> do - addMessageI Info MsgActionNoUsersSelected - redirect UsersR + | Set.null usersSet && isNotSetSupervisor act -> + addMessageI Info MsgActionNoUsersSelected (UserLdapSyncData, userSet) -> do runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseLdapUser uid - addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet - redirect UsersR + addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet + redirectKeepGetParams UsersR (UserHijack, Set.minView -> Just (uid, _)) -> hijackUser uid >>= sendResponse (UserRemoveSupervisorData, userSet) -> do runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet] addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet - redirect UsersR + redirectKeepGetParams UsersR (act, usersSet) | isActionSupervisor act -> do avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act @@ -382,8 +382,8 @@ postUsersR = do if nrSuperNotFound > 0 then addMessageI Warning $ MsgUsersChangeSupervisorsWarning (Set.size usersSet) (length supersFound) nrSuperNotFound else addMessageI Success $ MsgUsersChangeSupervisorsSuccess (Set.size usersSet) (length supersFound) - redirect UsersR - _other -> error "Should not be possible" + redirectKeepGetParams UsersR + _other -> addMessageI Warning MsgInvalidInput ((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 1ff03ffde..f7a43dd6a 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -137,3 +137,22 @@ redirectAlternatives = go Just xs' -> over _1 (x :) $ nunsnoc xs' nsnoc [] x = x :| [] nsnoc (x' : xs) x = x' :| (xs ++ [x]) + +-- | redirect to currentRoute, if Just otherwise to given default +reload :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a +reload r = getCurrentRoute >>= redirect . fromMaybe r + +-- | like `reload`, preserving all GET parameters +reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a +reloadKeepGetParams r = liftHandler $ do + getps <- reqGetParams <$> getRequest + route <- fromMaybe r <$> getCurrentRoute + -- addMessage Info $ toHtml (show getps) -- DEBUG ONLY + -- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")]) + redirect (route, getps) + +-- | redirect preserving all GET parameters +redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a +redirectKeepGetParams route = liftHandler $ do + getps <- reqGetParams <$> getRequest + redirect (route, getps) \ No newline at end of file diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 10b90e28f..076b1ac29 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -964,7 +964,7 @@ instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) En instance Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where def = DBParamsForm { dbParamsFormMethod = POST - , dbParamsFormAction = Nothing + , dbParamsFormAction = Nothing -- Recall: Nothing preserves GET Parameters , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = \_ -> return (pure (), mempty) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 9ad82b29f..c5f8ef383 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -307,7 +307,7 @@ data FormIdentifier | FIDAvsQueryLicence | FIDAvsSetLicence | FIDBtnAvsImportUnknown - | FIDBtnAvsRevokeUnknown + | FIDBtnAvsRevokeUnknown deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where @@ -1089,6 +1089,7 @@ wrapForm' :: Button site button => button -> WidgetT site IO () -> FormSettings wrapForm' btn formWidget FormSettings{..} = do formId <- maybe newIdent (return . toPathPiece) formAnchor formActionUrl <- traverse toTextUrl formAction + let hasAction = isJust formActionUrl $(widgetFile "widgets/form/form") diff --git a/templates/widgets/form/form.hamlet b/templates/widgets/form/form.hamlet index 7d4a7901f..371a7c701 100644 --- a/templates/widgets/form/form.hamlet +++ b/templates/widgets/form/form.hamlet @@ -5,7 +5,7 @@ $# $# SPDX-License-Identifier: AGPL-3.0-or-later $# Wrapper for all kinds of forms -
+ $# Distinguish different falvours of submit button layouts here: $case formSubmit $of FormNoSubmit From 014d479df8f36515915bc7991bb97bad24dcbef9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 25 Apr 2023 09:56:18 +0000 Subject: [PATCH 03/29] fix(users): prevent accidental user hijacking --- src/Handler/Users.hs | 4 ++-- src/Utils/Form.hs | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 3ae8c8885..1e20bdde1 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -45,7 +45,7 @@ import Auth.Dummy (apDummy) hijackUserForm :: Form () -hijackUserForm csrf = do +hijackUserForm = identifyForm FIDHijackUser $ \csrf -> do (btnResult, btnView) <- mopt (buttonField BtnHijack) "" Nothing return (btnResult >>= guard . is _Just, mconcat [toWidget csrf, fvWidget btnView]) @@ -351,7 +351,7 @@ postUsersR = do , dbtExtraReps = [] } - $logInfoS "UsersFormResult" $ tshow usersRes + -- $logInfoS "UsersFormResult" $ tshow usersRes formResult usersRes $ \case (act, usersSet) | Set.null usersSet && isNotSetSupervisor act -> diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index c5f8ef383..1cee75678 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -308,6 +308,7 @@ data FormIdentifier | FIDAvsSetLicence | FIDBtnAvsImportUnknown | FIDBtnAvsRevokeUnknown + | FIDHijackUser deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where From 32b1074dcaf949d8d9b9a50ec648820a1aadb4db Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 25 Apr 2023 10:41:48 +0000 Subject: [PATCH 04/29] chore(actions): keep filters for table actions on LMS, Qualifications and PrintCenter --- .../uniworx/categories/term/de-de-formal.msg | 4 ++-- messages/uniworx/utils/utils/de-de-formal.msg | 6 ++++-- messages/uniworx/utils/utils/en-eu.msg | 6 ++++-- src/Handler/LMS.hs | 17 +++++++---------- src/Handler/PrintCenter.hs | 10 ++++------ src/Handler/Qualification.hs | 18 ++++++++---------- src/Handler/Users.hs | 4 ++-- src/Handler/Utils.hs | 2 +- src/Utils/Form.hs | 2 +- 9 files changed, 33 insertions(+), 36 deletions(-) diff --git a/messages/uniworx/categories/term/de-de-formal.msg b/messages/uniworx/categories/term/de-de-formal.msg index 8a93e5698..80555c631 100644 --- a/messages/uniworx/categories/term/de-de-formal.msg +++ b/messages/uniworx/categories/term/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2023 Gregor Kleen ,Steffen Jost ,Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -14,7 +14,7 @@ TermEnd: Ende Kursperiode LectureStart: Beginn Kurse TermEdited tid@TermId: Semester #{tid} erfolgreich editiert. TermNewTitle: Semester editieren/anlegen. -InvalidInput: Eingaben bitte korrigieren. +InvalidInput: Ungültige Eingabe, bitte korrigieren. Term !ident-ok: Semester TermPlaceholder: JJJJ TermStartDay: Erster Tag diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 3dfdcd670..1d5b9d184 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Winnie Ros +# SPDX-FileCopyrightText: 2023 Steffen Jost ,Gregor Kleen ,Sarah Vaupel ,Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -150,4 +150,6 @@ SheetGradingPassPoints': Bestehen nach Punkten SheetGradingPassBinary': Bestanden/Nicht bestanden SheetGradingPassAlways': Automatisch bestanden, sobald korrigiert SheetTypeNormal !ident-ok: Normal -SheetTypeBonus !ident-ok: Bonus \ No newline at end of file +SheetTypeBonus !ident-ok: Bonus + +InvalidFormAction: Keine Aktion ausgeführt wegen ungültigen Formulardaten \ No newline at end of file diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 8e551020c..9162d42f4 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Winnie Ros +# SPDX-FileCopyrightText: 2023 Sarah Vaupel ,Winnie Ros ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -150,4 +150,6 @@ SheetGradingPassPoints': Passing by points SheetGradingPassBinary': Pass/Fail SheetGradingPassAlways': Automatically passed when corrected SheetTypeNormal: Normal -SheetTypeBonus: Bonus \ No newline at end of file +SheetTypeBonus: Bonus + +InvalidFormAction: No action taken due to invalid form data \ No newline at end of file diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 8b3f3d9db..7ec9be91b 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2023 Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -365,16 +365,14 @@ mkLmsTable :: forall h p cols act act'. -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) -> DB (FormResult (act', Set UserId), Widget) mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do - now <- liftIO getCurrentTime - currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here - let - -- currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali) -- bad idea as seen + now <- liftIO getCurrentTime + let nowaday = utctDay now mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "qualification" - dbtSQLQuery q = lmsTableQuery qid q + dbtSQLQuery = lmsTableQuery qid dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjId @@ -472,7 +470,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else DBParamsForm { dbParamsFormMethod = POST - , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional @@ -504,8 +502,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR postLmsR sid qsh = do - isAdmin <- hasReadAccessTo AdminR - currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler + isAdmin <- hasReadAccessTo AdminR ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do qent <- getBy404 $ SchoolQualificationShort sid qsh let acts :: Map LmsTableAction (AForm Handler LmsTableActionData) @@ -613,7 +610,7 @@ postLmsR sid qsh = do when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal numExaminees when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected - redirect currentRoute + reloadKeepGetParams $ LmsR sid qsh let heading = citext2widget $ "LMS " <> qualificationName quali siteLayout heading $ do diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index c6faa651e..cd3beeec1 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -157,8 +157,7 @@ pjTableQuery (printJob `E.LeftOuterJoin` recipient return (printJob, recipient, sender, course, quali) mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget) -mkPJTable = do - currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here +mkPJTable = do let dbtSQLQuery = pjTableQuery dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) @@ -227,7 +226,7 @@ mkPJTable = do dbtExtraReps = [] dbtParams = DBParamsForm { dbParamsFormMethod = POST - , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional @@ -254,8 +253,7 @@ mkPJTable = do getPrintCenterR, postPrintCenterR :: Handler Html getPrintCenterR = postPrintCenterR -postPrintCenterR = do - currentRoute <- fromMaybe (error "printCenterR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler +postPrintCenterR = do (pjRes, pjTable) <- runDB mkPJTable formResult pjRes $ \case @@ -263,7 +261,7 @@ postPrintCenterR = do now <- liftIO getCurrentTime num <- runDB $ updateWhereCount [PrintJobAcknowledged ==. Nothing, PrintJobId <-. pjIds] [PrintJobAcknowledged =. Just now] addMessageI Success $ MsgPrintJobAcknowledge num - redirect currentRoute + reloadKeepGetParams PrintCenterR siteLayoutMsg MsgMenuApc $ do setTitleI MsgMenuApc diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 242c3c355..11669a68c 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2023 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -294,8 +294,7 @@ mkQualificationTable :: -> DB (FormResult (QualificationTableActionData, Set UserId), Widget) mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do svs <- getSupervisees - now <- liftIO getCurrentTime - currentRoute <- fromMaybe (error "mkQualificationTable called from 404-handler") <$> liftHandler getCurrentRoute + now <- liftIO getCurrentTime let nowaday = utctDay now mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday @@ -303,7 +302,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do dbtIdent :: Text dbtIdent = "qualification" fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs - dbtSQLQuery q = qualificationTableQuery qid fltrSvs q + dbtSQLQuery = qualificationTableQuery qid fltrSvs dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjId -- FilteredPostId dbtColonnade = cols @@ -393,7 +392,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do dbtExtraReps = [] dbtParams = DBParamsForm { dbParamsFormMethod = POST - , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional @@ -419,8 +418,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html getQualificationR = postQualificationR -postQualificationR sid qsh = do - currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler +postQualificationR sid qsh = do isAdmin <- hasReadAccessTo AdminR ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh @@ -476,7 +474,7 @@ postQualificationR sid qsh = do let msgKind = if upd > 0 then Success else Warning msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire addMessageI msgKind msgVal - redirect currentRoute + reloadKeepGetParams $ QualificationR sid qsh (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do now <- liftIO getCurrentTime let nowaday = utctDay now @@ -498,8 +496,8 @@ postQualificationR sid qsh = do | isNothing qubr -> MsgQualificationStatusUnblock | otherwise -> MsgQualificationStatusBlock addMessageI warnLevel $ fbmsg qsh oks nrq - redirect currentRoute - _ -> addMessageI Error MsgUnauthorized + reloadKeepGetParams $ QualificationR sid qsh + _ -> addMessageI Error MsgInvalidFormAction let heading = citext2widget $ qualificationName quali siteLayout heading $ do diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 1e20bdde1..6961ac1f9 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -383,7 +383,7 @@ postUsersR = do then addMessageI Warning $ MsgUsersChangeSupervisorsWarning (Set.size usersSet) (length supersFound) nrSuperNotFound else addMessageI Success $ MsgUsersChangeSupervisorsSuccess (Set.size usersSet) (length supersFound) redirectKeepGetParams UsersR - _other -> addMessageI Warning MsgInvalidInput + _other -> addMessageI Error MsgInvalidFormAction ((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index f7a43dd6a..d13be8cee 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 1cee75678..1dfdc2703 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2023 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Wolfgang Witt -- -- SPDX-License-Identifier: AGPL-3.0-or-later From 0922723a85b97d51081484f4fa6a407b6451d0f7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 25 Apr 2023 10:42:16 +0000 Subject: [PATCH 05/29] chore(avs): reactivate avs development dummy --- src/Utils/Avs.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index abe528279..7dfe7148c 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -13,10 +13,10 @@ import qualified Data.Text as Text import Servant import Servant.Client --- #ifdef DEVELOPMENT --- #else +#ifdef DEVELOPMENT +#else import Servant.Client.Core (requestPath) --- #endif +#endif import Model.Types.Avs @@ -68,15 +68,15 @@ avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery --- #ifdef DEVELOPMENT --- mkAvsQuery _ _ _ = AvsQuery --- { avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty --- , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty --- , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing) --- , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty --- , avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty --- } --- #else +#ifdef DEVELOPMENT +mkAvsQuery _ _ _ = AvsQuery + { avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty + , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty + , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing) + , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty + , avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty + } +#else mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv , avsQueryStatus = \q -> liftIO $ runClientM (splitQuery rawQueryStatus q) cliEnv @@ -107,7 +107,7 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped') where s = view _Wrapped' q --- #endif +#endif ----------------------- -- Utility Functions -- From 5fcc85c9a029ce5826ff93b9e14eefac892ca2eb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 25 Apr 2023 13:10:19 +0000 Subject: [PATCH 06/29] refactor(login): clarify login fields --- messages/auth/campus/de.msg | 4 ++-- messages/auth/campus/en.msg | 4 ++-- messages/uniworx/categories/authorization/de-de-formal.msg | 6 +++--- messages/uniworx/categories/authorization/en-eu.msg | 6 +++--- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/messages/auth/campus/de.msg b/messages/auth/campus/de.msg index 8755ecf03..1812fdf28 100644 --- a/messages/auth/campus/de.msg +++ b/messages/auth/campus/de.msg @@ -2,7 +2,7 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later -CampusIdentPlaceholder: V.Nachname@fraport.de -CampusIdent: Fraport AG Kennung +CampusIdentPlaceholder: V.Nachname@fraport.de / E12345 +CampusIdent: Fraport Kennung CampusPassword: Passwort CampusPasswordPlaceholder: Passwort \ No newline at end of file diff --git a/messages/auth/campus/en.msg b/messages/auth/campus/en.msg index 55652d3fa..02ffd46fd 100644 --- a/messages/auth/campus/en.msg +++ b/messages/auth/campus/en.msg @@ -2,7 +2,7 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later -CampusIdentPlaceholder: F.Last@fraport.de -CampusIdent: Fraport AG account +CampusIdentPlaceholder: F.Last@fraport.de / E12345 +CampusIdent: Fraport account CampusPassword: Password CampusPasswordPlaceholder: Password \ No newline at end of file diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index e16240aa5..b7ee11560 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -96,9 +96,9 @@ TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei. ExamOccurrenceNoCapacity: Zu diesem Termin/Raum sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer:innen angemeldet. -LDAPLoginTitle: Fraport AG Login (Büko) -PWHashLoginTitle: FRADrive Login -PWHashLoginNote: Verwenden Sie dieses Formular für zugesandte FRADrive Logindaten. Angestellte der Fraport AG sollten stattdessen den Büko-Login verwenden! +LDAPLoginTitle: Fraport Login für interne und externe Nutzer +PWHashLoginTitle: Spezieller Funktionsnutzer Login +PWHashLoginNote: Verwenden Sie dieses Formular nur, wenn Sie explizit dazu aufgefordert wurden. Alle anderen sollten das andere Login Formular verwenden! DummyLoginTitle: Development-Login InternalLdapError: Interner Fehler beim Fraport Büko-Login CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg index d2ad99d62..59dad7860 100644 --- a/messages/uniworx/categories/authorization/en-eu.msg +++ b/messages/uniworx/categories/authorization/en-eu.msg @@ -97,9 +97,9 @@ TutorialNoCapacity: Tutorial has reached maximum capacity ExamOccurrenceNoCapacity: Occurrence/Room has reached maximum capacity CourseNotEmpty: There are currently no participants enrolled for this course. -LDAPLoginTitle: Fraport AG login (Büko) -PWHashLoginTitle: FRADrive login -PWHashLoginNote: Use this form if you have received special FRADrive credentials. Fraport AG employees should use the Büko login instead! +LDAPLoginTitle: Fraport login for intern and extern users +PWHashLoginTitle: Special function user login +PWHashLoginNote: Only use this login form if you have received special instructions to do so. All others should use the other login field. DummyLoginTitle: Development login InternalLdapError: Internal error during Fraport Büko login CampusUserInvalidIdent: Could not determine unique identification during Fraport Büko login From d973acf42b27645aa436dda389fed9411bace950 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 25 Apr 2023 14:43:50 +0000 Subject: [PATCH 07/29] chore(print): switch all letters to sans serif font --- templates/letter/din5008.latex | 3 ++- templates/letter/din5008with_pin.latex | 1 + templates/letter/plain_article.latex | 10 +++++++--- test/Database/Fill.hs | 2 +- 4 files changed, 11 insertions(+), 5 deletions(-) diff --git a/templates/letter/din5008.latex b/templates/letter/din5008.latex index c6c88f17e..0816d2ec5 100644 --- a/templates/letter/din5008.latex +++ b/templates/letter/din5008.latex @@ -66,7 +66,8 @@ $endif$ % if luatex or xetex \usepackage{fontspec} \setmonofont{DejaVu Sans Mono} -\fi +\fi +\renewcommand{\familydefault}{\sfdefault} $if(mathspec)$ \ifXeTeX diff --git a/templates/letter/din5008with_pin.latex b/templates/letter/din5008with_pin.latex index 22e3b0a0f..68047cc04 100644 --- a/templates/letter/din5008with_pin.latex +++ b/templates/letter/din5008with_pin.latex @@ -67,6 +67,7 @@ $endif$ \usepackage{fontspec} \setmonofont{DejaVu Sans Mono} \fi +\renewcommand{\familydefault}{\sfdefault} $if(mathspec)$ \ifXeTeX diff --git a/templates/letter/plain_article.latex b/templates/letter/plain_article.latex index e95489125..bdd9d7cd9 100644 --- a/templates/letter/plain_article.latex +++ b/templates/letter/plain_article.latex @@ -51,15 +51,19 @@ $endif$ \fi \ifPDFTeX + \usepackage{helvet} \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} \usepackage[utf8]{inputenc} - \usepackage{textcomp} % provide euro and other symbols - \usepackage{DejaVuSansMono} % better monofont + \usepackage{textcomp}% provide euro and other symbols + \usepackage{DejaVuSansMono}% better monofont + \renewcommand{\familydefault}{\sfdefault} \else % if luatex or xetex \usepackage{fontspec} + %\setmainfont{TeXGyreHeros}%could not install the package somehow tex-gyre in default.nix/shell.nix did not work + \setmainfont{DejaVu Sans} \setmonofont{DejaVu Sans Mono} - %\renewcommand{\familydefault}{\sfdefault} + \renewcommand{\familydefault}{\sfdefault} \fi $if(mathspec)$ diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index b5f4549ba..13c67c30c 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -932,7 +932,7 @@ fillDb = do

Benötigte Unterlagen