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

Merge branch 'master' into fradrive/cr3

Browse Source
This commit is contained in:
Steffen Jost 2024-02-13 10:16:40 +01:00
commit ce4869f155
36 changed files with 646 additions and 198 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
CHANGELOG.md
View File

@ -2,6 +2,23 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
## [27.4.58](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.57...v27.4.58) (2024-02-08)
### Bug Fixes
* **health:** negative interface routes working as intended now ([3303c4e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3303c4eebf928e527d2f9c1eb6e2495c10b94b13))
* **lms:** previouly failed notifications will be sent again ([263894b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/263894b05899ce55635d790f5334729fbc655ecc))
## [27.4.57](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.56...v27.4.57) (2024-02-06)
### Bug Fixes
* **course:** fix [#147](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/147) abort addd participant aborts now ([d332c0c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d332c0c11afd8b1dfe1343659f0b1626c968bbde))
* **health:** fix [#151](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/151) by offering route /health/interface/* ([c71814d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c71814d1ef1efc16c278136dfd6ebd86bd1d20db))
* **health:** fix [#153](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/153) and offer interface health route matching ([ce3852e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ce3852e3d365e62b32d181d58b7cbcc749e49373))
## [27.4.56](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.55...v27.4.56) (2023-12-20) ## [27.4.56](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.55...v27.4.56) (2023-12-20)

7
messages/uniworx/categories/admin/de-de-formal.msg
View File

@ -121,6 +121,13 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen
ProblemsAvsErrorHeading: Fehlermeldungen ProblemsAvsErrorHeading: Fehlermeldungen
ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit
InterfacesOk: Schnittstellen sind ok.
InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}!
InterfaceStatus !ident-ok: Status
InterfaceName: Schnittstelle
InterfaceLastSynch: Zuletzt InterfaceLastSynch: Zuletzt
InterfaceSubtype: Betreffend InterfaceSubtype: Betreffend
InterfaceWrite: Schreibend InterfaceWrite: Schreibend
InterfaceSuccess: Rückmeldung
InterfaceInfo: Nachricht
InterfaceFreshness: Prüfungszeitraum (h)

7
messages/uniworx/categories/admin/en-eu.msg
View File

@ -121,6 +121,13 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences
ProblemsAvsErrorHeading: Error Log ProblemsAvsErrorHeading: Error Log
ProblemsInterfaceSince: Only considering successes and errors since ProblemsInterfaceSince: Only considering successes and errors since
InterfacesOk: Interfaces are ok.
InterfacesFail n: #{pluralENsN n "interface problem"}!
InterfaceStatus: Status
InterfaceName: Interface
InterfaceLastSynch: Last InterfaceLastSynch: Last
InterfaceSubtype: Affecting InterfaceSubtype: Affecting
InterfaceWrite: Write InterfaceWrite: Write
InterfaceSuccess: Returned
InterfaceInfo: Message
InterfaceFreshness: Check hours

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

@ -23,6 +23,7 @@ MenuPayments: Zahlungsbedingungen
MenuInstance: Instanz-Identifikation MenuInstance: Instanz-Identifikation
MenuHealth: Instanz-Zustand MenuHealth: Instanz-Zustand
MenuHealthInterface: Schnittstellen Zustand
MenuHelp: Hilfe MenuHelp: Hilfe
MenuProfile: Anpassen MenuProfile: Anpassen
MenuLogin !ident-ok: Login MenuLogin !ident-ok: Login
@ -145,6 +146,8 @@ MenuLdap: LDAP Schnittstelle
MenuApc: Druckerei MenuApc: Druckerei
MenuPrintSend: Manueller Briefversand MenuPrintSend: Manueller Briefversand
MenuPrintDownload: Brief herunterladen MenuPrintDownload: Brief herunterladen
MenuPrintLog: LPR Schnittstelle
MenuPrintAck: Druckbestätigung
MenuApiDocs: API-Dokumentation (Englisch) MenuApiDocs: API-Dokumentation (Englisch)
MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger) MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)

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

@ -23,6 +23,7 @@ MenuPayments: Payment Terms
MenuInstance: Instance identification MenuInstance: Instance identification
MenuHealth: Instance health MenuHealth: Instance health
MenuHealthInterface: Interface health
MenuHelp: Support MenuHelp: Support
MenuProfile: Settings MenuProfile: Settings
MenuLogin: Login MenuLogin: Login
@ -145,6 +146,8 @@ MenuLdap: LDAP Interface
MenuApc: Printing MenuApc: Printing
MenuPrintSend: Send Letter MenuPrintSend: Send Letter
MenuPrintDownload: Download Letter MenuPrintDownload: Download Letter
MenuPrintLog: LPR Interface
MenuPrintAck: Acknowledge Printing
MenuApiDocs: API documentation MenuApiDocs: API documentation
MenuSwagger: OpenAPI 2.0 (Swagger) MenuSwagger: OpenAPI 2.0 (Swagger)

15
models/audit.model
View File

@ -14,9 +14,18 @@ TransactionLog
InterfaceLog InterfaceLog
interface Text interface Text
subtype Text subtype Text
write Bool -- requestMethod /= GET, i.e. True implies a write to FRADrive write Bool -- requestMethod /= GET, i.e. True implies a write to FRADrive
time UTCTime time UTCTime
rows Int Maybe -- number of datasets transmitted rows Int Maybe -- number of datasets transmitted
info Text -- addtional status information info Text -- addtional status information
success Bool default=true -- false logs a failure; but it will be overwritten by next transaction, but logged in TransactionLog
UniqueInterfaceSubtypeWrite interface subtype write UniqueInterfaceSubtypeWrite interface subtype write
deriving Eq Read Show Generic deriving Eq Read Show Generic
InterfaceHealth
interface Text
subtype Text Maybe
write Bool Maybe
hours Int
UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique
deriving Eq Read Show Generic

2
models/lms.model
View File

@ -20,7 +20,7 @@ Qualification
SchoolQualificationShort school shorthand -- must be unique per school and shorthand SchoolQualificationShort school shorthand -- must be unique per school and shorthand
SchoolQualificationName school name -- must be unique per school and name SchoolQualificationName school name -- must be unique per school and name
-- across all schools, only one qualification may be a driving licence: -- across all schools, only one qualification may be a driving licence:
UniqueQualificationAvsLicence avsLicence !force UniqueQualificationAvsLicence avsLicence !force -- either empty or unique
-- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints! -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints!
deriving Eq Generic deriving Eq Generic

2
nix/docker/version.json
View File

@ -1,3 +1,3 @@
{ {
"version": "27.4.56" "version": "27.4.58"
} }

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{ {
"name": "uni2work", "name": "uni2work",
"version": "27.4.56", "version": "27.4.58",
"lockfileVersion": 1, "lockfileVersion": 1,
"requires": true, "requires": true,
"dependencies": { "dependencies": {

2
package.json
View File

@ -1,6 +1,6 @@
{ {
"name": "uni2work", "name": "uni2work",
"version": "27.4.56", "version": "27.4.58",
"description": "", "description": "",
"keywords": [], "keywords": [],
"author": "", "author": "",

2
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx name: uniworx
version: 27.4.56 version: 27.4.58
dependencies: dependencies:
- base - base
- yesod - yesod

32
routes
View File

@ -79,24 +79,26 @@
/print PrintCenterR GET POST !system-printer /print PrintCenterR GET POST !system-printer
/print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer /print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer
/print/acknowledge/direct PrintAckDirectR POST !system-printer /print/acknowledge/direct PrintAckDirectR GET POST !system-printer
/print/send PrintSendR GET POST /print/send PrintSendR GET POST
/print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer /print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer
/print/log PrintLogR GET !system-printer
/health HealthR GET !free /health HealthR GET !free
/instance InstanceR GET !free /health/interface/+Texts HealthInterfaceR GET !free
/info InfoR GET !free /instance InstanceR GET !free
/info/lecturer InfoLecturerR GET !free /info InfoR GET !free
/info/supervisor InfoSupervisorR GET !free /info/lecturer InfoLecturerR GET !free
/info/legal LegalR GET !free /info/supervisor InfoSupervisorR GET !free
/info/glossary GlossaryR GET !free /info/legal LegalR GET !free
/info/faq FaqR GET !free /info/glossary GlossaryR GET !free
/info/terms-of-use TermsOfUseR GET !free /info/faq FaqR GET !free
/info/payments PaymentsR GET !free /info/terms-of-use TermsOfUseR GET !free
/imprint ImprintR GET !free /info/payments PaymentsR GET !free
/data-protection DataProtectionR GET !free /imprint ImprintR GET !free
/version VersionR GET !free /data-protection DataProtectionR GET !free
/status StatusR GET !free /version VersionR GET !free
/status StatusR GET !free
/help HelpR GET POST !free /help HelpR GET POST !free

1
src/Application.hs
View File

@ -145,6 +145,7 @@ import Handler.Material
import Handler.CryptoIDDispatch import Handler.CryptoIDDispatch
import Handler.SystemMessage import Handler.SystemMessage
import Handler.Health import Handler.Health
import Handler.Health.Interface
import Handler.Exam import Handler.Exam
import Handler.ExamOffice import Handler.ExamOffice
import Handler.Metrics import Handler.Metrics

40
src/Audit.hs
View File

@ -8,7 +8,7 @@ module Audit
, audit , audit
, AuditRemoteException(..) , AuditRemoteException(..)
, getRemote , getRemote
, logInterface , logInterface, logInterface'
) where ) where
@ -123,19 +123,49 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User
) )
=> Text -- ^ Interface that is used => Text -- ^ Interface that is used
-> Text -- ^ Subtype of the interface, if any -> Text -- ^ Subtype of the interface, if any
-> Bool -- ^ Success=True, Failure=False
-> Maybe Int -- ^ Number of transmitted datasets -> Maybe Int -- ^ Number of transmitted datasets
-> Text -- ^ Any additional information -> Text -- ^ Any additional information
-> ReaderT (YesodPersistBackend (HandlerSite m)) m () -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
-- ^ Log a transaction using information available from `HandlerT`, also calls `audit` -- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
logInterface interfaceLogInterface interfaceLogSubtype interfaceLogRows interfaceLogInfo = do logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do
interfaceLogTime <- liftIO getCurrentTime
interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest
deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert is correct here, since we want to repalce the it logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo
insert_ InterfaceLog{..}
logInterface' :: ( AuthId (HandlerSite m) ~ Key User
, IsSqlBackend (YesodPersistBackend (HandlerSite m))
, SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
, HasInstanceID (HandlerSite m) InstanceId
, YesodAuthPersist (HandlerSite m)
, MonadHandler m
, MonadCatch m
, HasAppSettings (HandlerSite m)
, HasCallStack
)
=> Text -- ^ Interface that is used
-> Text -- ^ Subtype of the interface, if any
-> Bool -- ^ True indicates Write Access to FRADrive
-> Bool -- ^ Success=True, Failure=False
-> Maybe Int -- ^ Number of transmitted datasets
-> Text -- ^ Any additional information
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
-- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogWrite interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do
interfaceLogTime <- liftIO getCurrentTime
-- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- deleteBy & insert would be justified here, leading to a new Row-ID, since the two rows are not truly connected.
-- insert_ InterfaceLog{..}
void $ upsertBy (UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite)
( InterfaceLog{..} )
[ InterfaceLogTime =. interfaceLogTime
, InterfaceLogRows =. interfaceLogRows
, InterfaceLogInfo =. interfaceLogInfo
, InterfaceLogSuccess =. interfaceLogSuccess
]
audit TransactionInterface audit TransactionInterface
{ transactionInterfaceName = interfaceLogInterface { transactionInterfaceName = interfaceLogInterface
, transactionInterfaceSubtype = interfaceLogSubtype , transactionInterfaceSubtype = interfaceLogSubtype
, transactionInterfaceWrite = interfaceLogWrite , transactionInterfaceWrite = interfaceLogWrite
, transactionInterfaceRows = interfaceLogRows , transactionInterfaceRows = interfaceLogRows
, transactionInterfaceInfo = interfaceLogInfo , transactionInterfaceInfo = interfaceLogInfo
, transactionInterfaceSuccess = Just interfaceLogSuccess
} }

1
src/Audit/Types.hs
View File

@ -240,6 +240,7 @@ data Transaction
, transactionInterfaceWrite :: Bool -- True implies a write to FRADrive , transactionInterfaceWrite :: Bool -- True implies a write to FRADrive
, transactionInterfaceRows :: Maybe Int , transactionInterfaceRows :: Maybe Int
, transactionInterfaceInfo :: Text , transactionInterfaceInfo :: Text
, transactionInterfaceSuccess :: Maybe Bool -- Just False implies a failure; Maybe used to achieve backwards compatibility
} }
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)

7
src/Database/Esqueleto/Utils.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de> -- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -17,6 +17,7 @@ module Database.Esqueleto.Utils
, (>~.), (<~.) , (>~.), (<~.)
, or, and , or, and
, any, all , any, all
, not__, parens
, subSelectAnd, subSelectOr , subSelectAnd, subSelectOr
, mkExactFilter, mkExactFilterWith, mkExactFilterWithComma , mkExactFilter, mkExactFilterWith, mkExactFilterWithComma
, mkExactFilterLast, mkExactFilterLastWith , mkExactFilterLast, mkExactFilterLastWith
@ -252,6 +253,9 @@ subSelectOr q = parens . E.subSelectUnsafe $ flip (E.unsafeSqlAggregateFunction
parens :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) parens :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
parens = E.unsafeSqlFunction "" parens = E.unsafeSqlFunction ""
-- | Workaround for Esqueleto-Bug not placing parenthesis after NOT, see #155
not__ :: E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool)
not__ = E.not_ . parens
-- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples -- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples
$(sqlInTuples [2..16]) $(sqlInTuples [2..16])
@ -705,7 +709,6 @@ interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text
singleQuote = Text.Builder.singleton '\'' singleQuote = Text.Builder.singleton '\''
wrapSqlString b = singleQuote <> b <> singleQuote wrapSqlString b = singleQuote <> b <> singleQuote
infixl 6 `diffDays`, `diffTimes` infixl 6 `diffDays`, `diffTimes`
diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int) diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int)

43
src/Foundation/Navigation.hs
View File

@ -133,7 +133,8 @@ breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR 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 PrintAckR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed
breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintAck $ Just PrintCenterR
breadcrumb PrintLogR = i18nCrumb MsgMenuPrintLog $ Just PrintCenterR
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
breadcrumb (SchoolR ssh sRoute) = case sRoute of breadcrumb (SchoolR ssh sRoute) = case sRoute of
@ -164,9 +165,10 @@ breadcrumb FaqR = i18nCrumb MsgBreadcrumbFaq $ Just InfoR
breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing
breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing
breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing breadcrumb (HealthInterfaceR _) = i18nCrumb MsgMenuHealthInterface (Just HealthR)
breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing
breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed
breadcrumb QualificationAllR = i18nCrumb MsgMenuQualifications Nothing 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
@ -1333,6 +1335,17 @@ pageActions HealthR = return
} }
, navChildren = [] , navChildren = []
} }
, NavPageActionPrimary
{ navLink = NavLink
{ navLabel = MsgMenuHealthInterface
, navRoute = HealthInterfaceR []
, navAccess' = NavAccessTrue
, navType = NavTypeLink { navModal = False }
, navQuick' = mempty
, navForceActive = False
}
, navChildren = []
}
] ]
pageActions InstanceR = return pageActions InstanceR = return
[ NavPageActionPrimary [ NavPageActionPrimary
@ -2435,8 +2448,28 @@ pageActions PrintCenterR = do
, navForceActive = False , navForceActive = False
} }
} }
printLog = NavPageActionSecondary
{ navLink = NavLink
{ navLabel = MsgMenuPrintLog
, navRoute = PrintLogR
, navAccess' = NavAccessTrue
, navType = NavTypeLink { navModal = False }
, navQuick' = mempty
, navForceActive = False
}
}
printAck = NavPageActionSecondary
{ navLink = NavLink
{ navLabel = MsgMenuPrintAck
, navRoute = PrintAckDirectR
, navAccess' = NavAccessTrue
, navType = NavTypeLink { navModal = False }
, navQuick' = mempty
, navForceActive = False
}
}
dayLinks <- mapM toDayAck $ Map.toAscList dayMap dayLinks <- mapM toDayAck $ Map.toAscList dayMap
return $ manualSend : take 9 dayLinks return $ manualSend : printLog : printAck : take 9 dayLinks
pageActions AdminCrontabR = return pageActions AdminCrontabR = return
[ NavPageActionPrimary [ NavPageActionPrimary

80
src/Handler/Admin.hs
View File

@ -24,6 +24,7 @@ import qualified Database.Esqueleto.Utils as E
import Handler.Utils import Handler.Utils
import Handler.Utils.Avs import Handler.Utils.Avs
import Handler.Utils.Users import Handler.Utils.Users
import Handler.Health.Interface
import Handler.Admin.Test as Handler.Admin import Handler.Admin.Test as Handler.Admin
import Handler.Admin.ErrorMessage as Handler.Admin import Handler.Admin.ErrorMessage as Handler.Admin
@ -54,13 +55,15 @@ getAdminProblemsR = do
flagNonZero n | n <= 0 = flagError True flagNonZero n | n <= 0 = flagError True
| otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n)) | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))
(usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, interfaceTable) <- runDB $ (,,,,,) (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,)
<$> areAllUsersReachable <$> areAllUsersReachable
<*> allDriversHaveAvsId now <*> allDriversHaveAvsId now
<*> allRDriversHaveFs now <*> allRDriversHaveFs now
<*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime]) <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime])
<*> (not <$> exists [PrintAcknowledgeProcessed ==. False]) <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
<*> fmap (view _2) (mkInterfaceLogTable flagError cutOffOldTime) <*> mkInterfaceLogTable flagError mempty
let interfacesBadNr = length $ filter (not . snd) interfaceOks
-- interfacesOk = all snd interfaceOks
diffLics <- try retrieveDifferingLicences >>= \case diffLics <- try retrieveDifferingLicences >>= \case
-- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
(Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
@ -235,76 +238,3 @@ retrieveDriversRWithoutF now = do
E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld) E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
E.&&. E.notExists (hasValidQual AvsLicenceVorfeld) E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
return usr return usr
mkInterfaceLogTable :: (Bool -> Widget) -> UTCTime -> DB (Any, Widget)
mkInterfaceLogTable flagError cutOffOldTime = do
avsSynchStats <- E.select $ do
uavs <- E.from $ E.table @UserAvs
E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime
let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError)
E.groupBy isOk
E.orderBy [E.descNullsLast isOk]
return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch)
let
mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do
fmtCut <- formatTime SelFormatDate cutOffOldTime
fmtBad <- formatTime SelFormatDateTime badTime
return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad
mkBadInfo _ _ = return mempty
writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo =
void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True)
(InterfaceLog "AVS" "Synch" True okTime okRows badInfo)
[InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo]
--case $(unValueN 3) <$> avsSynchStats of
case avsSynchStats of
((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) ->
writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime
((E.Value True , E.Value okRows, E.Value okTime):_) ->
writeAvsSynchStats (Just okRows) okTime mempty
((E.Value False, E.Value badRows, E.Value badTime):_) -> do
lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime
_ -> return ()
let
flagOld = flagError . (cutOffOldTime <)
resultDBTable = DBTable{..}
where
resultILog :: Lens' (DBRow (Entity InterfaceLog)) InterfaceLog
resultILog = _dbrOutput . _entityVal
dbtSQLQuery = return
dbtRowKey = (E.^. InterfaceLogId)
dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat
[ sortable Nothing (textCell "Status" ) $ wgtCell . flagOld . view (resultILog . _interfaceLogTime)
, sortable (Just "interface") (textCell "Interface" ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
, sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype)
, sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
, sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime)
, sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows)
, sortable Nothing (textCell "Info" ) $ \(view resultILog -> ilt) -> case ilt of
InterfaceLog "AVS" "Synch" True _ _ i -> anchorCell ProblemAvsErrorR $ toWgt i
InterfaceLog _ _ _ _ _ i -> textCell i
]
dbtSorting = mconcat
[ singletonMap "interface" $ SortColumn (E.^. InterfaceLogInterface)
, singletonMap "subtype" $ SortColumn (E.^. InterfaceLogSubtype)
, singletonMap "write" $ SortColumn (E.^. InterfaceLogWrite)
, singletonMap "time" $ SortColumn (E.^. InterfaceLogTime)
, singletonMap "rows" $ SortColumn (E.^. InterfaceLogRows)
]
dbtFilter = mempty
dbtFilterUI = mempty
dbtStyle = def
dbtIdent = "interface-log" :: Text
dbtParams = def
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
resultDBTableValidator = def
& defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
dbTable resultDBTableValidator resultDBTable

6
src/Handler/Course/Edit.hs
View File

@ -279,8 +279,8 @@ getCourseNewR = do
, E.desc $ courseCreated course] -- most recent created course , E.desc $ courseCreated course] -- most recent created course
E.limit 1 E.limit 1
return course return course
template <- case listToMaybe oldCourses of template <- case oldCourses of
(Just oldTemplate) -> (oldTemplate:_) ->
let newTemplate = courseToForm oldTemplate mempty mempty in let newTemplate = courseToForm oldTemplate mempty mempty in
return $ Just $ newTemplate return $ Just $ newTemplate
{ cfCourseId = Nothing { cfCourseId = Nothing
@ -289,7 +289,7 @@ getCourseNewR = do
, cfRegTo = Nothing , cfRegTo = Nothing
, cfDeRegUntil = Nothing , cfDeRegUntil = Nothing
} }
Nothing -> do [] -> do
(tidOk,sshOk,cshOk) <- runDB $ (,,) (tidOk,sshOk,cshOk) <- runDB $ (,,)
<$> ifMaybeM mbTid True existsKey <$> ifMaybeM mbTid True existsKey
<*> ifMaybeM mbSsh True existsKey <*> ifMaybeM mbSsh True existsKey

251
src/Handler/Health/Interface.hs Normal file
View File

@ -0,0 +1,251 @@
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
module Handler.Health.Interface
(
getHealthInterfaceR
, mkInterfaceLogTable
, runInterfaceChecks
)
where
import Import
-- import qualified Data.Set as Set
import qualified Data.Text as Text
import Handler.Utils
import Handler.Utils.Concurrent
-- import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Legacy as EL (on)
import qualified Database.Persist.Sql as E (deleteWhereCount)
-- | identify a wildcard argument
wc2null :: Text -> Maybe Text
-- wc2null "." = Nothing -- does not work, since dots are eliminated in URLs
-- wc2null "-" = Nothing -- used as wildcard subtype in lpr interface
wc2null "_" = Nothing
wc2null "*" = Nothing
wc2null o = Just o
-- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool
pbool :: Text -> Maybe Bool
pbool (Text.toLower . Text.strip -> w)
| w `elem` ["1", "t", "true" ,"wahr", "w"] = Just True
| w `elem` ["0", "f", "false","falsch"] = Just False
| otherwise = Nothing
-- | parse UniqueInterfaceHealth with subtype and write arguments being optional for the last interface. Wildcards '_' or '.' are also allowed in all places.
identifyInterfaces :: [Text] -> [Unique InterfaceHealth]
identifyInterfaces [] = []
identifyInterfaces [i] = [UniqueInterfaceHealth i Nothing Nothing]
identifyInterfaces [i,s] = [UniqueInterfaceHealth i (wc2null s) Nothing]
identifyInterfaces (i:s:w:r) = UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r
type ReqBanInterfaceHealth = ([Unique InterfaceHealth],[Unique InterfaceHealth])
-- | Interface names prefixed with '-' are to be excluded from the query
splitInterfaces :: [Unique InterfaceHealth] -> ReqBanInterfaceHealth
splitInterfaces = foldl' aux mempty
where
aux (reqs,bans) uih@(UniqueInterfaceHealth i s w)
| Just ('-', b) <- Text.uncons i = (reqs, UniqueInterfaceHealth b s w : bans)
| otherwise = (uih : reqs, bans)
-- | check whether the first argument is equal or more specialzed (i.e. more Just) than the second
matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool
matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw
where
eqOrNothing _ Nothing = True
eqOrNothing a b = a == b
getHealthInterfaceR :: [Text] -> Handler TypedContent
getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force"
let interfs = splitInterfaces $ identifyInterfaces ris
(missing, allok, res, iltable) <- runInterfaceLogTable interfs
when missing notFound -- send 404 if any requested interface was not found
let ihstatus = if allok then status200
else internalServerError500
plainMsg = if allok then "Interfaces are healthy."
else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res]
sendResponseStatus ihstatus <=< selectRep $ do -- most browsers send accept:text/html, thus text/plain can be default here
provideRep . return . RepPlain $ toContent plainMsg -- /?_accept=text/plain
provideRep . siteLayoutMsg MsgMenuHealthInterface $ do -- /?_accept=text/html
setTitleI MsgMenuHealthInterface
[whamlet|
<div>
#{plainMsg}
<div>
^{iltable}
|]
runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget)
runInterfaceLogTable interfs@(reqIfs,_) = do
-- we abuse messageTooltip for colored icons here
msgSuccessTooltip <- messageI Success MsgMessageSuccess
-- msgWarningTooltip <- messageI Warning MsgMessageWarning
msgErrorTooltip <- messageI Error MsgMessageError
let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
(res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs
let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ]
allok = all snd res
return (missing, allok, res, twgt)
-- ihDebugShow :: Unique InterfaceHealth -> Text
-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")"
mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
-- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs])
void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs
now <- liftIO getCurrentTime
dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}
where
sanitize = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü']
dbtIdent = "interface-log" :: Text
dbtProj = dbtProjId
dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do
EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface
E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype)
E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite )
)
let matchUIH crits = E.or
[ E.and $ catMaybes
[ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) & Just
, (ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize <$> subt
, (ilog E.^. InterfaceLogWrite E.==.) . E.val <$> writ
]
| (UniqueInterfaceHealth ifce subt writ) <- crits
]
matchUIHnot crits = E.and
[ E.or $ catMaybes
[ ilog E.^. InterfaceLogInterface E.!=. E.val (sanitize ifce) & Just
, (ilog E.^. InterfaceLogSubtype E.!=.) . E.val . sanitize <$> subt
, (ilog E.^. InterfaceLogWrite E.!=.) . E.val <$> writ
]
| (UniqueInterfaceHealth ifce subt writ) <- crits
]
unless (null reqIfs) $ E.where_ $ matchUIH reqIfs
unless (null banIfs) $ E.where_ $ matchUIHnot banIfs
-- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs -- !!! DOES NOT WORK !!! Yields strange results, see #155
-- unless (null banIfs) $ E.where_ $ E.not_ $ E.parens $ matchUIH banIfs -- WORKS OKAY
-- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD All missing, except for "Printer" "F"
-- E.where_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY
-- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- WORKS OKAY
let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead
return (ilog, ihour)
queryILog :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog)
queryILog = $(E.sqlLOJproj 2 1)
resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog
resultILog = _dbrOutput . _1 . _entityVal
resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) Int
resultHours = _dbrOutput . _2 . E._unValue
dbtRowKey = queryILog >>> (E.^.InterfaceLogId)
colonnade now = mconcat
[ sortable Nothing (i18nCell MsgInterfaceStatus) $ \row -> -- do
let hours = row ^. resultHours
-- defmsg = row ^? resultErrMsg
logtime = row ^. resultILog . _interfaceLogTime
success = row ^. resultILog . _interfaceLogSuccess
iface = row ^. resultILog . _interfaceLogInterface
status = success && now <= addHours hours logtime
in tellCell [(iface,status)] $
wgtCell $ flagError status
, sortable (Just "interface") (i18nCell MsgInterfaceName ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
, sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype)
, sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
, sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime)
, sortable Nothing (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours
, sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows)
, sortable (Just "success") (i18nCell MsgInterfaceSuccess ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s
, sortable Nothing (i18nCell MsgInterfaceInfo ) $ \(view resultILog -> ilt) -> case ilt of
InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR $ toWgt $ bool i "AVS-Log" $ null i
InterfaceLog "LPR" _ _ _ _ i _ -> anchorCell PrintLogR $ toWgt $ bool i "LPR-Log" $ null i
InterfaceLog _ _ _ _ _ i _ -> textCell i
]
dbtSorting = mconcat
[ singletonMap "interface" $ SortColumn $ queryILog >>> (E.^. InterfaceLogInterface)
, singletonMap "subtype" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSubtype)
, singletonMap "write" $ SortColumn $ queryILog >>> (E.^. InterfaceLogWrite)
, singletonMap "time" $ SortColumn $ queryILog >>> (E.^. InterfaceLogTime)
, singletonMap "rows" $ SortColumn $ queryILog >>> (E.^. InterfaceLogRows)
, singletonMap "success" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSuccess)
]
ilvalidator = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
dbtFilter = mempty
dbtFilterUI = mempty
dbtStyle = def
dbtParams = def
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
-- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call
runInterfaceChecks :: ReqBanInterfaceHealth -> DB ()
runInterfaceChecks interfs = do
avsInterfaceCheck interfs
lprAckCheck interfs
maybeRunCheck :: ReqBanInterfaceHealth -> Unique InterfaceHealth -> (UTCTime -> DB ()) -> DB ()
maybeRunCheck (reqIfs,banIfs) uih act
| null reqIfs || any (matchesUniqueInterfaceHealth uih) reqIfs
, null banIfs || not (any (matchesUniqueInterfaceHealth uih) banIfs) = do
mih <- getBy uih
whenIsJust mih $ \eih -> do
now <- liftIO getCurrentTime
act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now
| otherwise = return ()
lprAckCheck :: ReqBanInterfaceHealth -> DB ()
lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do
unproc <- selectList [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. False] []
if notNull unproc
then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist"
else do
oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True]
if oks > 0
then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed"
else mkLog True Nothing mempty
where
mkLog = logInterface' "Printer" "Acknowledge" True
avsInterfaceCheck :: ReqBanInterfaceHealth -> DB ()
avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \cutOffOldTime -> do
avsSynchStats <- E.select $ do
uavs <- E.from $ E.table @UserAvs
E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime
let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError)
E.groupBy isOk
E.orderBy [E.descNullsLast isOk]
return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch)
let
mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do
fmtCut <- formatTime SelFormatDate cutOffOldTime
fmtBad <- formatTime SelFormatDateTime badTime
return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad
mkBadInfo _ _ = return mempty
writeAvsSynchStats okRows badInfo =
logInterface' "AVS" "Synch" True (null badInfo) okRows badInfo
--case $(unValueN 3) <$> avsSynchStats of
case avsSynchStats of
((E.Value True , E.Value okRows, E.Value _okTime):(E.Value False, E.Value badRows, E.Value badTime):_) ->
writeAvsSynchStats (Just okRows) =<< mkBadInfo badRows badTime
((E.Value True , E.Value okRows, E.Value _okTime):_) ->
writeAvsSynchStats (Just okRows) mempty
((E.Value False, E.Value badRows, E.Value badTime):_) ->
-- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime
_ -> return ()

2
src/Handler/LMS/Learners.hs
View File

@ -213,6 +213,6 @@ getLmsLearnersDirectR sid qsh = do
$logInfoS "LMS" msg $logInfoS "LMS" msg
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
<* runDB (logInterface "LMS" (ciOriginal qsh) (Just nr) "") <* runDB (logInterface "LMS" (ciOriginal qsh) True (Just nr) "")
-- direct Download see: -- direct Download see:
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

4
src/Handler/LMS/Report.hs
View File

@ -295,7 +295,6 @@ postLmsReportUploadR sid qsh = do
[whamlet|$newline never [whamlet|$newline never
<form method=post enctype=#{enctype}> <form method=post enctype=#{enctype}>
^{widget} ^{widget}
<p>
<input type=submit> <input type=submit>
|] |]
@ -315,12 +314,13 @@ postLmsReportDirectR sid qsh = do
case enr of case enr of
Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
$logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e $logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e
logInterface "LMS" (ciOriginal qsh) False Nothing ""
return (badRequest400, "Exception: " <> tshow e) return (badRequest400, "Exception: " <> tshow e)
Right nr -> do Right nr -> do
let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". "
$logInfoS "LMS" msg $logInfoS "LMS" msg
when (nr > 0) $ queueDBJob $ JobLmsReports qid when (nr > 0) $ queueDBJob $ JobLmsReports qid
logInterface "LMS" (ciOriginal qsh) (Just nr) "" logInterface "LMS" (ciOriginal qsh) True (Just nr) ""
return (ok200, msg) return (ok200, msg)
[] -> do [] -> do
let msg = "Report upload file missing." let msg = "Report upload file missing."

72
src/Handler/PrintCenter.hs
View File

@ -10,7 +10,8 @@ module Handler.PrintCenter
, getPrintCenterR, postPrintCenterR , getPrintCenterR, postPrintCenterR
, getPrintSendR , postPrintSendR , getPrintSendR , postPrintSendR
, getPrintAckR , postPrintAckR , getPrintAckR , postPrintAckR
, postPrintAckDirectR , getPrintAckDirectR, postPrintAckDirectR
, getPrintLogR
) where ) where
import Import import Import
@ -26,7 +27,7 @@ import Database.Esqueleto.Utils.TH
import Utils.Print import Utils.Print
-- import Data.Aeson (encode) import qualified Data.Aeson as Aeson
-- import qualified Data.Text as Text -- import qualified Data.Text as Text
-- import qualified Data.Set as Set -- import qualified Data.Set as Set
@ -441,6 +442,21 @@ postPrintAckR ackDay numAck chksm = do
saveApcident :: UTCTime -> Natural -> Text -> JobDB Natural saveApcident :: UTCTime -> Natural -> Text -> JobDB Natural
saveApcident t i apci = insert_ (PrintAcknowledge apci t False) >> return (succ i) saveApcident t i apci = insert_ (PrintAcknowledge apci t False) >> return (succ i)
makeAckUploadForm :: Form FileInfo
makeAckUploadForm = renderAForm FormStandard $ fileAFormReq "Acknowledge APC-Ident CSV"
getPrintAckDirectR :: Handler Html
getPrintAckDirectR = do
(widget, enctype) <- generateFormPost makeAckUploadForm
siteLayoutMsg MsgMenuPrintAck $ do
setTitleI MsgMenuPrintAck
[whamlet|$newline never
<form method=post enctype=#{enctype}>
^{widget}
<input type=submit>
|]
postPrintAckDirectR :: Handler Html postPrintAckDirectR :: Handler Html
postPrintAckDirectR = do postPrintAckDirectR = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
@ -471,3 +487,55 @@ postPrintAckDirectR = do
$logErrorS "APC" msg $logErrorS "APC" msg
return (badRequest400, msg) return (badRequest400, msg)
sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back
getPrintLogR :: Handler Html
getPrintLogR = do
let
logDBTable = DBTable{..}
where
resultLog :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) TransactionLog
resultLog = _dbrOutput . _1
resultTrans :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) (Aeson.Result Transaction)
resultTrans = _dbrOutput . _2
tCell' err c dbr = case view resultTrans dbr of
(Aeson.Error msg) -> err msg -- should not happen, due to query filter
(Aeson.Success t) -> c t
tCellErr = tCell' stringCell
tCell = tCell' $ const mempty
dbtIdent = "lpr-log" :: Text
dbtSQLQuery l = do
E.where_ $ E.val "LPR" E.==. l E.^. TransactionLogInfo E.->>. "interface-name"
-- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary
return l
dbtRowKey = (E.^. TransactionLogId)
dbtProj = dbtProjSimple $ \(Entity _ l) -> do
return (l, Aeson.fromJSON $ transactionLogInfo l)
dbtColonnade = dbColonnade $ mconcat
[ sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t
, sortable (Just "status") (textCell "Status") $ tCell (cellMaybe iconBoolCell . transactionInterfaceSuccess)
, sortable (Just "subtype") (i18nCell MsgInterfaceSubtype) $ tCell ( textCell . transactionInterfaceSubtype)
, sortable (Just "info") (i18nCell MsgSystemMessageContent) $ tCellErr ( textCell . transactionInterfaceInfo)
]
dbtSorting = mconcat
[ singletonMap "time" $ SortColumn (E.^. TransactionLogTime)
, singletonMap "status" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-success")
, singletonMap "subtype" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-subtype")
, singletonMap "info" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-info" )
]
dbtFilter = mempty
dbtFilterUI = mempty
dbtStyle = def
dbtParams = def
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
validator = def & defaultSorting [ SortDescBy "time" ]
tbl <- runDB $ dbTableDB' validator logDBTable
siteLayoutMsg MsgMenuPrintLog $ do
setTitleI MsgMenuPrintLog
[whamlet|^{tbl}|]

2
src/Handler/SAP.hs
View File

@ -141,7 +141,7 @@ getQualificationSAPDirectR = do
msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
quals = Text.intercalate ", " $ nubOrd $ mapMaybe (view (_2 . E._unValue)) qualUsers quals = Text.intercalate ", " $ nubOrd $ mapMaybe (view (_2 . E._unValue)) qualUsers
$logInfoS "SAP" msg $logInfoS "SAP" msg
let logInt = runDB $ logInterface "SAP" quals (Just nr) "" let logInt = runDB $ logInterface "SAP" quals True (Just nr) ""
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt

2
src/Handler/Utils.hs
View File

@ -35,6 +35,8 @@ import Handler.Utils.Qualification as Handler.Utils
import Handler.Utils.Term as Handler.Utils import Handler.Utils.Term as Handler.Utils
-- import Handler.Utils.Concurrent as Handler.Utils -- only imported when needed
import Control.Monad.Logger import Control.Monad.Logger

38
src/Handler/Utils/Concurrent.hs Normal file
View File

@ -0,0 +1,38 @@
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
module Handler.Utils.Concurrent
( module Handler.Utils.Concurrent
) where
-- NOTE: use `retrySTM` and `checkSTM` instead of `retry` or `check`
import Import
import UnliftIO.Concurrent as Handler.Utils.Concurrent hiding (yield)
-- | Run a handler action until it finishes or if it exceeds a given number of microseconds via `registerDelay`
timeoutHandler :: Int -> HandlerFor site a -> HandlerFor site (Maybe a)
timeoutHandler maxWait act = do
innerAct <- handlerToIO
(hresult, tid) <- liftIO $ do
hresult <- newTVarIO Nothing
tid <- forkIO $ do
res <- innerAct act
atomically $ writeTVar hresult $ Just res
return (hresult, tid)
res <- liftIO $ do
flag <- registerDelay maxWait
atomically $ do
out <- readTVar flag
res <- readTVar hresult
checkSTM $ out || isJust res
return res
case res of
Nothing -> liftIO $ do
killThread tid
readTVarIO hresult -- read once more after kill to ensure that any result is noticed
_ -> return res

4
src/Handler/Utils/DateTime.hs
View File

@ -93,8 +93,8 @@ toMorning = toTimeOfDay 6 0 0
toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime
toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..} toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..}
addHours :: Integer -> UTCTime -> UTCTime addHours :: Integral n => n -> UTCTime -> UTCTime
addHours = addUTCTime . secondsToNominalDiffTime . fromInteger . (* 3600) addHours = addUTCTime . secondsToNominalDiffTime . fromIntegral . (* 3600)
instance HasLocalTime UTCTime where instance HasLocalTime UTCTime where
toLocalTime = utcToLocalTime toLocalTime = utcToLocalTime

2
src/Handler/Utils/Users.hs
View File

@ -189,7 +189,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y
toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of toSql user pl = bool id E.not__ (is _PLNegated pl) $ case pl ^. _plVar of
GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation') GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation')
GuessUserEduPersonPrincipalName userEPPN' -> user E.^. UserLdapPrimaryKey E.==. E.val (Just userEPPN') GuessUserEduPersonPrincipalName userEPPN' -> user E.^. UserLdapPrimaryKey E.==. E.val (Just userEPPN')
GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName' GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName'

8
src/Jobs.hs
View File

@ -47,7 +47,7 @@ import qualified Control.Monad.Catch as Exc
import Data.Time.Zones import Data.Time.Zones
import Control.Concurrent.STM (stateTVar, retry) import Control.Concurrent.STM (stateTVar)
import Control.Concurrent.STM.Delay import Control.Concurrent.STM.Delay
import UnliftIO.Concurrent (forkIO, myThreadId, threadDelay) import UnliftIO.Concurrent (forkIO, myThreadId, threadDelay)
@ -260,7 +260,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc ->
(nextVal, newQueue) <- MaybeT . lift . fmap jqDequeue $ readTVar chan (nextVal, newQueue) <- MaybeT . lift . fmap jqDequeue $ readTVar chan
lift . lift $ writeTVar chan newQueue lift . lift $ writeTVar chan newQueue
jobWorkers' <- lift . lift $ jobWorkers <$> readTMVar appJobState jobWorkers' <- lift . lift $ jobWorkers <$> readTMVar appJobState
receiver <- maybe (lift $ lift retry) return =<< uniformMay jobWorkers' receiver <- maybe (lift $ lift retrySTM) return =<< uniformMay jobWorkers'
return (nextVal, receiver) return (nextVal, receiver)
whenIsJust next $ \(nextVal, receiver) -> do whenIsJust next $ \(nextVal, receiver) -> do
atomically $ readTVar receiver >>= jqInsert nextVal >>= (writeTVar receiver $!) atomically $ readTVar receiver >>= jqInsert nextVal >>= (writeTVar receiver $!)
@ -373,8 +373,8 @@ execCrontab = do
State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
prevExec <- State.get prevExec <- State.get
case earliestJob settings prevExec crontab refT of case earliestJob settings prevExec crontab refT of
Nothing -> liftBase retry Nothing -> liftBase retrySTM
Just (_, MatchNone) -> liftBase retry Just (_, MatchNone) -> liftBase retrySTM
Just x -> return (crontab, x, prevExec) Just x -> return (crontab, x, prevExec)
do do

13
src/Jobs/Handler/LMS.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de> -- SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -117,7 +117,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
} }
forM_ renewalUsers (queueDBJob . usr_job) forM_ renewalUsers (queueDBJob . usr_job)
logInterface "LMS" (qshort <> "-enq") (Just $ length renewalUsers) "" logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
@ -201,7 +201,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
-- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid -- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid
-- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- E.&&. E.isNothing (luser E.^. LmsUserStatus)
-- E.&&. E.isNothing (luser E.^. LmsUserEnded) -- E.&&. E.isNothing (luser E.^. LmsUserEnded)
E.&&. E.not_ (validQualification now quser) E.&&. E.not__ (validQualification now quser)
pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser) pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser)
nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ] let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ]
@ -222,7 +222,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
`E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId `E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId
E.&&. qblock `isLatestBlockBefore` E.val now E.&&. qblock `isLatestBlockBefore` E.val now
) )
E.where_ $ -- E.not_ (validQualification now quser) -- currently invalid E.where_ $ -- E.not__ (validQualification now quser) -- currently invalid
quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification
E.&&. quserToNotify now quser qblock -- recently became invalid or blocked E.&&. quserToNotify now quser qblock -- recently became invalid or blocked
pure (quser E.^. QualificationUserUser) pure (quser E.^. QualificationUserUser)
@ -258,7 +258,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers] deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers]
-- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] -- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers]
deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ] deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ]
logInterface "LMS" (qshort <> "-deq") (Just nrBlocked) (tshow nrExpired <> " expired") logInterface "LMS" (qshort <> "-deq") True (Just nrBlocked) (tshow nrExpired <> " expired")
dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX
@ -312,7 +312,8 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
E.&&. lreport E.^. LmsReportLock E.==. E.true E.&&. lreport E.^. LmsReportLock E.==. E.true
) )
-- B) notify all newly reported users that lms is available -- B) notify all newly reported users that lms is available
let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting let luserFltrNew luser = E.isNothing (luser E.^. LmsUserReceived) -- not seen before, just starting
E.||. E.isNothing (luser E.^. LmsUserNotified) -- a previous notification has failed
notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } } notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } }
in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner
-- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry

4
src/Jobs/Types.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de> -- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -375,6 +375,8 @@ jobNoQueueSame = \case
notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame
notifyNoQueueSame = \case notifyNoQueueSame = \case
NotificationQualificationRenewal{} -> Just JobNoQueueSame -- send one at once; safe, since the job is rescheduled if sending was not acknowledged NotificationQualificationRenewal{} -> Just JobNoQueueSame -- send one at once; safe, since the job is rescheduled if sending was not acknowledged
NotificationQualificationExpiry{} -> Just JobNoQueueSame -- do not send multiple expiry messages to the same person at once
NotificationQualificationExpired{} -> Just JobNoQueueSame
_ -> Nothing _ -> Nothing
jobMovable :: JobCtl -> Bool jobMovable :: JobCtl -> Bool

27
src/Model/Migration/Definitions.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de> -- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -49,7 +49,8 @@ import qualified Data.Time.Zones as TZ
data ManualMigration data ManualMigration
= Migration20230524QualificationUserBlock = Migration20230524QualificationUserBlock
| Migration20230703LmsUserStatus | Migration20230703LmsUserStatus
| Migration20240124UniquenessCompanyAvsNr | Migration20240212InitInterfaceHealth -- create table interface_health and fill with default values
| Migration20240224UniquenessCompanyAvsNr
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite)
@ -178,7 +179,26 @@ customMigrations = mapF $ \case
; ;
|] |]
Migration20240124UniquenessCompanyAvsNr -> Migration20240212InitInterfaceHealth ->
unlessM (tableExists "interface_health") $ do -- fill health table with some defaults
[executeQQ|
CREATE TABLE "interface_health"
( id BIGSERIAL NOT NULL
, interface CHARACTER VARYING NOT NULL
, subtype CHARACTER VARYING
, write BOOLEAN
, hours BIGINT NOT NULL
, PRIMARY KEY(id)
, CONSTRAINT unique_interface_health UNIQUE(interface, subtype, write)
);
INSERT INTO "interface_health" ("interface", "subtype", "write", "hours")
VALUES
('Printer', 'Acknowledge', True, 168)
, ('AVS' , 'Synch' , True , 96)
ON CONFLICT DO NOTHING;
|]
Migration20240224UniquenessCompanyAvsNr ->
whenM (tableExists "company" `and2M` notM (indexExists "unique_company_avs_id")) $ do -- companies with avs_id == 0 can be deleted; company users are deleted automatically by cascade whenM (tableExists "company" `and2M` notM (indexExists "unique_company_avs_id")) $ do -- companies with avs_id == 0 can be deleted; company users are deleted automatically by cascade
[executeQQ| [executeQQ|
DELETE FROM "company" WHERE avs_id = 0; DELETE FROM "company" WHERE avs_id = 0;
@ -186,7 +206,6 @@ customMigrations = mapF $ \case
|] |]
tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
tableExists table = do tableExists table = do
haveTable <- [sqlQQ| SELECT to_regclass(#{table}); |] haveTable <- [sqlQQ| SELECT to_regclass(#{table}); |]

9
src/Utils.hs
View File

@ -324,9 +324,16 @@ citext2string = Text.unpack . CI.original
string2citext :: String -> CI Text string2citext :: String -> CI Text
string2citext = CI.mk . Text.pack string2citext = CI.mk . Text.pack
text2AlphaNumPlus :: [Char] -> Text -> Text
text2AlphaNumPlus =
let alphaNum = Set.fromAscList $ ['0'..'9'] <> ['A'..'Z'] <> ['a'..'z']
in \oks ->
let aNumPlus = Set.fromList oks <> alphaNum
in Text.filter (`Set.member` aNumPlus)
-- | Convert or remove all non-ascii characters, e.g. for filenames -- | Convert or remove all non-ascii characters, e.g. for filenames
text2asciiAlphaNum :: Text -> Text text2asciiAlphaNum :: Text -> Text
text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c) text2asciiAlphaNum = text2AlphaNumPlus ['-','_']
. Text.replace "ä" "ae" . Text.replace "ä" "ae"
. Text.replace "Ä" "Ae" . Text.replace "Ä" "Ae"
. Text.replace "Æ" "ae" . Text.replace "Æ" "ae"

1
src/Utils/Lens.hs
View File

@ -312,6 +312,7 @@ makeLenses_ ''AuthorshipStatementDefinition
makeLenses_ ''PrintJob makeLenses_ ''PrintJob
makeLenses_ ''InterfaceLog makeLenses_ ''InterfaceLog
-- makeLenses_ ''InterfaceLog -- not needed
-------------------------- --------------------------
-- Fields for `UniWorX` -- -- Fields for `UniWorX` --

24
src/Utils/Print.hs
View File

@ -269,13 +269,17 @@ printLetter' pji pdf = do
-- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code
printJobFile = LBS.toStrict pdf printJobFile = LBS.toStrict pdf
printJobAcknowledged = Nothing printJobAcknowledged = Nothing
qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get
let logInter = flip (logInterface "Printer" qshort) (Just 1)
lprPDF printJobFilename pdf >>= \case lprPDF printJobFilename pdf >>= \case
Left err -> do Left err -> do
logInter False err
return $ Left err return $ Left err
Right ok -> do Right ok -> do
printJobCreated <- liftIO getCurrentTime printJobCreated <- liftIO getCurrentTime
-- updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows -- updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows
insert_ PrintJob {..} insert_ PrintJob{..}
logInter True ok
return $ Right (ok, printJobFilename) return $ Right (ok, printJobFilename)
reprintPDF :: Bool -> PrintJobId -> DB (Either Text Text) reprintPDF :: Bool -> PrintJobId -> DB (Either Text Text)
@ -283,13 +287,19 @@ reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown."
where where
reprint :: PrintJob -> DB (Either Text Text) reprint :: PrintJob -> DB (Either Text Text)
reprint pj@PrintJob{..} = do reprint pj@PrintJob{..} = do
qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get
let logInter = flip (logInterface "Printer" qshort) (Just 1)
result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile
whenIsRight result $ const $ do case result of
now <- liftIO getCurrentTime Left err ->
insert_ pj{ printJobAcknowledged = Nothing logInter False err
, printJobCreated = now Right m -> do
-- , printJobApcIdent = ??? cannot be modified here, since it is included inside the PDF logInter True m
} now <- liftIO getCurrentTime
insert_ pj{ printJobAcknowledged = Nothing
, printJobCreated = now
-- , printJobApcIdent = ??? cannot be modified here, since it is included inside the PDF
}
return result return result
{- {-

5
templates/admin-problems.hamlet
View File

@ -57,7 +57,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{MsgMenuInterfaces} _{MsgMenuInterfaces}
<div> <div>
<p> <p>
_{MsgProblemsInterfaceSince} ^{formatTimeW SelFormatDate cutOffOldTime} $if interfacesBadNr > 0
_{MsgInterfacesFail interfacesBadNr}
$else
_{MsgInterfacesOk}
^{interfaceTable} ^{interfaceTable}
<!-- section h2 {MsgProblemsHeadingMisc} --> <!-- section h2 {MsgProblemsHeadingMisc} -->