chore(daily): towards #2347 by performing AVS queries/updates
actual checking of retrieved values is still a todo
This commit is contained in:
parent
ce164f308f
commit
612a931d36
@ -6,6 +6,7 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- TODO during development only
|
||||
{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO during development only
|
||||
{-# OPTIONS_GHC -fno-warn-unused-matches #-} -- TODO during development only
|
||||
|
||||
module Handler.School.DayTasks
|
||||
( getSchoolDayR, postSchoolDayR
|
||||
@ -17,6 +18,7 @@ import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Company
|
||||
import Handler.Utils.Occurrences
|
||||
import Handler.Utils.Avs
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
@ -106,7 +108,7 @@ data DailyCacheKeys
|
||||
|
||||
-- | like the previous version above, but also returns the lessons occurring within the given time frame
|
||||
-- Due to caching, we only use the more informative version, unless experiments with the full DB show otherwise
|
||||
getDayTutorials :: SchoolId -> (Day,Day) -> DB (Map TutorialId [LessonTime])
|
||||
getDayTutorials :: SchoolId -> (Day,Day) -> DB (Map TutorialId (TutorialName, [LessonTime]))
|
||||
getDayTutorials ssh dlimit@(dstart, dend )
|
||||
| dstart > dend = return mempty
|
||||
| otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (CacheKeyTutorialOccurrences ssh dlimit) $ do
|
||||
@ -121,11 +123,11 @@ getDayTutorials ssh dlimit@(dstart, dend )
|
||||
-- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates
|
||||
return $ foldMap checkCandidate candidates
|
||||
where
|
||||
checkCandidate :: (Entity Term, Entity Tutorial) -> Map TutorialId [LessonTime]
|
||||
checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}})
|
||||
checkCandidate :: (Entity Term, Entity Tutorial) -> Map TutorialId (TutorialName, [LessonTime])
|
||||
checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ, tutorialName=tName}})
|
||||
| let lessons = Set.filter lessonFltr $ occurringLessons trm occ
|
||||
, notNull lessons
|
||||
= Map.singleton tutId $ Set.toAscList lessons -- due to Set not having a Functor instance, we need mostly need lists anyway
|
||||
= Map.singleton tutId (tName , Set.toAscList lessons) -- due to Set not having a Functor instance, we need mostly need lists anyway
|
||||
| otherwise
|
||||
= mempty
|
||||
|
||||
@ -479,10 +481,10 @@ mkDailyTable isAdmin ssh nd = getDayTutorials ssh (nd,nd) >>= \case
|
||||
= row ^. resultCourse . _entityVal
|
||||
tutName = row ^. resultTutorial . _entityVal . _tutorialName
|
||||
in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName
|
||||
, sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons
|
||||
, sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False . snd) $ Map.lookup tutId tutLessons
|
||||
, sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) ->
|
||||
-- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell
|
||||
cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons
|
||||
cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ snd <$> Map.lookup tutId tutLessons
|
||||
-- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now
|
||||
, sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell
|
||||
-- , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid
|
||||
@ -665,16 +667,36 @@ postSchoolDayR ssh nd = do
|
||||
-- | Prüft die Teilnehmer der Tagesansicht: AVS online aktualisieren, gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen
|
||||
getSchoolDayCheckR :: SchoolId -> Day -> Handler Html
|
||||
getSchoolDayCheckR ssh nd = do
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
-- isAdmin <- hasReadAccessTo AdminR
|
||||
(tuts, parts_avs) <- runDB $ do
|
||||
tuts <- Map.keys <$> getDayTutorials ssh (nd,nd)
|
||||
-- participants <- selectList [TutorialParticipantTutorial <-. tuts] []
|
||||
parts_avs <- E.select $ do
|
||||
(tpa :& avs) <- E.from $ E.table @TutorialParticipant
|
||||
`E.leftJoin` E.table @UserAvs
|
||||
`E.on` (\(tpa :& avs) -> tpa E.^. TutorialParticipantUser E.=?. avs E.?. UserAvsUser)
|
||||
E.where_ $ tpa E.^. TutorialParticipantTutorial `E.in_` E.vals tuts
|
||||
E.orderBy [E.asc $ tpa E.^. TutorialParticipantTutorial]
|
||||
return (tpa, avs E.?. UserAvsPersonId) -- , avs E.?. UserAvsNoPerson)
|
||||
-- additionally queue proper AVS synchs for all users, unless there were already done today
|
||||
void $ queueAvsUpdateByUID (foldMap (^. _1 . _entityVal . _tutorialParticipantUser . to Set.singleton) parts_avs) (Just nowaday)
|
||||
return (tuts, parts_avs)
|
||||
-- avsStats :: Map AvsPersonId AvsDataPerson
|
||||
avsStats <- catchAVShandler False False True mempty $ lookupAvsUsers $ foldMap (foldMap Set.singleton . E.unValue . snd) parts_avs -- query AVS, but does not affect DB (no update)
|
||||
|
||||
-- runDB $ do
|
||||
-- tuts <- getDayTutorials ssh (nd,nd)
|
||||
-- TODO CONTINUE HERE
|
||||
-- gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen
|
||||
-- traverse part_avs sorted by tuts, lookup name and check each person
|
||||
|
||||
dday <- formatTime SelFormatDate nd
|
||||
siteLayoutMsg MsgMenuSchoolDayCheck $ do
|
||||
setTitleI MsgMenuSchoolDayCheck
|
||||
[whamlet|
|
||||
TODO: this is just a stub.
|
||||
_{MsgMenuSchoolDay ssh dday}
|
||||
<h1>
|
||||
TODO: this is just a stub!
|
||||
<p>
|
||||
_{MsgMenuSchoolDay ssh dday}
|
||||
<p>
|
||||
#{tshow (Map.size avsStats)}
|
||||
|]
|
||||
@ -13,6 +13,7 @@ module Handler.Utils.Avs
|
||||
, upsertAvsUserByCard
|
||||
, upsertAvsUserById
|
||||
, updateAvsUserByIds
|
||||
, updateAvsUserByADC
|
||||
, linktoAvsUserByUIDs
|
||||
, queueAvsUpdateByUID, queueAvsUpdateByAID
|
||||
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
|
||||
@ -29,6 +30,7 @@ module Handler.Utils.Avs
|
||||
-- CR3
|
||||
, SomeAvsQuery(..)
|
||||
, queryAvsCardNo, queryAvsCardNos
|
||||
, catchAVShandler
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -717,6 +719,7 @@ upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi u
|
||||
oldSupId <- getOldId
|
||||
reportAdminProblem $ AdminProblemCompanySuperiorNotFound mbSupEmail cid oldSupId
|
||||
|
||||
-- | queue AVS synch for several UserIds, if a day is given, the last synch must be before the date to trigger an update
|
||||
queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64
|
||||
queueAvsUpdateByUID uids = queueAvsUpdateAux (E.table @User) (E.^. UserId) (\usr -> usr E.^. UserId `E.in_` E.vals uids)
|
||||
|
||||
|
||||
@ -8,6 +8,7 @@ module Jobs.Handler.SynchroniseAvs
|
||||
-- , dispatchJobSynchroniseAvsUser
|
||||
, dispatchJobSynchroniseAvsQueue
|
||||
, dispatchJobSynchroniseAvsLicences
|
||||
, dispatchJobSynchroniseByAvsDataContact
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -185,3 +186,8 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel
|
||||
when (synchLevel >= 3) $ procLic AvsLicenceVorfeld False $ fltrIds avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld
|
||||
when (synchLevel >= 4) $ procLic AvsLicenceRollfeld True $ fltrIds avsLicenceDiffGrantRollfeld --grant Rollfeld
|
||||
|
||||
|
||||
-- | delayed exection of already received contact info
|
||||
dispatchJobSynchroniseByAvsDataContact :: AvsDataContact -> JobHandler UniWorX
|
||||
dispatchJobSynchroniseByAvsDataContact adc =
|
||||
JobHandlerException . runDB . void $ updateAvsUserByADC adc
|
||||
@ -102,6 +102,9 @@ data Job
|
||||
, jIteration :: Natural
|
||||
, jSynchAfter :: Maybe Day
|
||||
}
|
||||
| JobSynchroniseByAvsDataContact
|
||||
{ jAvsDataContact :: AvsDataContact
|
||||
}
|
||||
-- JobSynchroniseAvsUser { jUser :: UserId
|
||||
-- , jSynchAfter :: Maybe Day
|
||||
-- }
|
||||
|
||||
@ -104,8 +104,8 @@ composeAddress street zipcode city country = toMaybe (notNull compAddr) compAddr
|
||||
-------------------
|
||||
|
||||
newtype AvsInternalPersonalNo = AvsInternalPersonalNo { avsInternalPersonalNo :: Text } -- ought to be all digits
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Binary)
|
||||
deriving (Eq, Ord, Show, Read, Generic)
|
||||
deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Binary, Hashable)
|
||||
instance E.SqlString AvsInternalPersonalNo
|
||||
-- AvsInternalPersonalNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API
|
||||
|
||||
@ -346,7 +346,7 @@ instance FromJSON AvsDataCardColor where
|
||||
parseJSON invalid = prependFailure "parsing AvsDataCardColor failed, " (typeMismatch "String" invalid)
|
||||
|
||||
|
||||
data AvsDataPersonCard = AvsDataPersonCard
|
||||
data AvsDataPersonCard = AvsDataPersonCard -- returned by AvsQueryPerson and partially by AvsQueryStatus
|
||||
{ avsDataValid :: Bool -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans
|
||||
, avsDataValidTo :: Maybe Day -- Nothing if returned with AvsResponseStatus
|
||||
, avsDataIssueDate :: Maybe Day -- Nothing if returned with AvsResponseStatus
|
||||
@ -548,7 +548,7 @@ data AvsPersonInfo = AvsPersonInfo
|
||||
, avsInfoPersonEMail :: Maybe Text
|
||||
, avsInfoPersonMobilePhoneNo :: Maybe Text
|
||||
, avsInfoInternalPersonalNo :: Maybe AvsInternalPersonalNo -- Fraport Personalnummer
|
||||
} deriving (Eq, Ord, Show, Generic, NFData, Binary)
|
||||
} deriving (Eq, Ord, Show, Read, Generic, NFData, Binary, Hashable)
|
||||
|
||||
makeLenses_ ''AvsPersonInfo
|
||||
|
||||
@ -594,7 +594,7 @@ data AvsFirmCommunication = AvsFirmCommunication
|
||||
, avsCommunicationCountry :: Maybe Text
|
||||
, avsCommunicationStreetANDHouseNo :: Maybe Text
|
||||
, avsCommunicationEMail :: Maybe Text
|
||||
} deriving (Eq, Ord, Show, Generic, NFData, Binary)
|
||||
} deriving (Eq, Ord, Show, Read, Generic, NFData, Binary, Hashable)
|
||||
|
||||
instance {-# OVERLAPS #-} Canonical (Maybe AvsFirmCommunication) where
|
||||
canonical (Just AvsFirmCommunication{..})
|
||||
@ -641,7 +641,7 @@ data AvsFirmInfo = AvsFirmInfo
|
||||
, avsFirmEMail :: Maybe Text
|
||||
, avsFirmEMailSuperior :: Maybe Text
|
||||
, avsFirmCommunication :: Maybe AvsFirmCommunication
|
||||
} deriving (Eq, Ord, Show, Generic, NFData, Binary)
|
||||
} deriving (Eq, Ord, Show, Read, Generic, NFData, Binary, Hashable)
|
||||
|
||||
makeLenses_ ''AvsFirmInfo
|
||||
-- additional convenience lenses:
|
||||
@ -725,7 +725,7 @@ data AvsDataContact = AvsDataContact
|
||||
{ avsContactPersonID :: AvsPersonId
|
||||
, avsContactPersonInfo :: AvsPersonInfo
|
||||
, avsContactFirmInfo :: AvsFirmInfo
|
||||
} deriving (Eq, Ord, Show, Generic, NFData, Binary)
|
||||
} deriving (Eq, Ord, Show, Read, Generic, NFData, Binary, Hashable)
|
||||
|
||||
makeLenses_ ''AvsDataContact
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user