diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 2c04c2a5c..7cefeec17 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -16,6 +16,7 @@ import Import import qualified Control.Monad.State.Class as State -- import Data.Aeson (encode) import qualified Data.Text as Text +import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Map as Map @@ -294,23 +295,25 @@ nullaryPathPiece ''LicenceTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''LicenceTableAction id data LicenceTableActionData = LicenceTableChangeAvsData - | LicenceTableRevokeFDriveData - | LicenceTableGrantFDriveData { licenceTableChangeFDriveEnd :: Day } + | LicenceTableRevokeFDriveData --TODO: add { licenceTableChangeFDriveQId :: QualificationId to avoid lookup later + | LicenceTableGrantFDriveData { licenceTableChangeFDriveQId :: QualificationId + , licenceTableChangeFDriveEnd :: Day + } deriving (Eq, Ord, Read, Show, Generic, Typeable) postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html postProblemAvsSynchR = getProblemAvsSynchR getProblemAvsSynchR = do + _now <- liftIO getCurrentTime + let _nowaday = utctDay now - -- TODO: just for Testing - -- now <- liftIO getCurrentTime + -- TODO: just for Testing -- let TimeOfDay hours minutes _seconds = timeToTimeOfDay (utctDayTime now) -- setTo0 = Set.fromList [AvsPersonId hours, AvsPersonId minutes, AvsPersonId 12345678] -- setTo1 = Set.fromList [AvsPersonId minutes] -- setTo2 = Set.fromList [AvsPersonId hours, AvsPersonId 12345678] - -- addMessageI Success $ MsgAvsSetLicences AvsLicenceVorfeld 99 1000 - + (setTo0, setTo1, setTo2) <- try retrieveDifferingLicences >>= \case Right res -> return res Left err -> do addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) @@ -345,7 +348,7 @@ getProblemAvsSynchR = do | otherwise -> addMessageI Info MsgRevokeUnknownLicencesOk Left err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect ProblemAvsSynchR - + ((tres0,tb0),(tres1,tb1),(tres2,tb2)) <- runDB $ (,,) <$> mkLicenceTable "driveSynchNoLicence" AvsNoLicence setTo0 (Just LicenceTableChangeAvs) <*> mkLicenceTable "driveSynchVorfeld" AvsLicenceVorfeld setTo1 (Just LicenceTableChangeAvs) @@ -358,7 +361,10 @@ getProblemAvsSynchR = do in addMessageI mkind $ MsgAvsSetLicences aLic no_ok no_req (Left err) -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) redirect ProblemAvsSynchR -- reload to update all tables - procRes _alic r@(_, _apids) = addMessage Info $ toHtml $ tshow r + -- procRes alic (LicenceTableRevokeFDriveData, apids) = do -- TODO: continue here !!! + -- qId <- runDB $ getBy UniqueQualificationAvsLicence alic + -- procRes alic (LicenceTableGrantFDriveData{..}, apids ) = do -- TODO: continue here !!! + procRes _alic r@(_, _apids) = addMessage Error $ toHtml $ "NOT YET IMPLEMENTED !!! " <> tshow r formResult tres2 $ procRes AvsLicenceRollfeld formResult tres1 $ procRes AvsLicenceVorfeld formResult tres0 $ procRes AvsNoLicence @@ -411,6 +417,7 @@ instance HasUser LicenceTableData where mkLicenceTable :: Text -> AvsLicence -> Set AvsPersonId -> Maybe LicenceTableAction -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget) mkLicenceTable dbtIdent aLic apids defAct = do currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute + avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [] now <- liftIO getCurrentTime let nowaday = utctDay now fltrLic qual = if @@ -457,12 +464,22 @@ mkLicenceTable dbtIdent aLic apids defAct = do [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) ] + qualOpt :: Entity Qualification -> Handler (Option QualificationId) + qualOpt (Entity qualId qual) = do + cQualId :: CryptoUUIDQualification <- encrypt qualId + return $ Option + { optionDisplay = CI.original $ qualificationName qual + , optionInternalValue = qualId + , optionExternalValue = tshow cQualId + } acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData) acts = mconcat [ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData - , if aLic == AvsNoLicence - then singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing - else singletonMap LicenceTableRevokeFDrive $ pure LicenceTableRevokeFDriveData + , if aLic /= AvsNoLicence + then singletonMap LicenceTableRevokeFDrive $ pure LicenceTableRevokeFDriveData + else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData + <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) Nothing + <*> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing ] dbtParams = DBParamsForm { dbParamsFormMethod = POST