|
|
|
|
@ -11,6 +11,7 @@ module Handler.Admin.Avs
|
|
|
|
|
( getAdminAvsR, postAdminAvsR
|
|
|
|
|
, getAdminAvsUserR
|
|
|
|
|
, getProblemAvsSynchR, postProblemAvsSynchR
|
|
|
|
|
, getProblemAvsErrorR
|
|
|
|
|
) where
|
|
|
|
|
|
|
|
|
|
import Import
|
|
|
|
|
@ -79,7 +80,7 @@ makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateA
|
|
|
|
|
validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler ()
|
|
|
|
|
validateAvsQueryPerson = do
|
|
|
|
|
AvsQueryPerson{..} <- State.get
|
|
|
|
|
guardValidation MsgAvsQueryEmpty $
|
|
|
|
|
guardValidation MsgAvsQueryEmpty $
|
|
|
|
|
is _Just avsPersonQueryCardNo ||
|
|
|
|
|
is _Just avsPersonQueryFirstName ||
|
|
|
|
|
is _Just avsPersonQueryLastName ||
|
|
|
|
|
@ -111,7 +112,7 @@ makeAvsContactForm tmpl = identifyForm FIDAvsQueryContact . validateForm validat
|
|
|
|
|
where
|
|
|
|
|
parseAvsIds :: Text -> AvsQueryContact
|
|
|
|
|
parseAvsIds txt = AvsQueryContact $ Set.fromList ids
|
|
|
|
|
where
|
|
|
|
|
where
|
|
|
|
|
nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
|
|
|
|
|
ids = mapMaybe (fmap AvsObjPersonId . readMay) nonemptys
|
|
|
|
|
unparseAvsIds :: AvsQueryContact -> Text
|
|
|
|
|
@ -156,7 +157,7 @@ postAdminAvsR = do
|
|
|
|
|
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
|
|
|
|
Right (AvsResponsePerson pns) -> return $ Just [whamlet|
|
|
|
|
|
<ul>
|
|
|
|
|
$forall p <- pns
|
|
|
|
|
$forall p <- pns
|
|
|
|
|
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|
|
|
|
|
|]
|
|
|
|
|
mbPerson <- formResultMaybe presult procFormPerson
|
|
|
|
|
@ -169,7 +170,7 @@ postAdminAvsR = do
|
|
|
|
|
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
|
|
|
|
Right (AvsResponseStatus pns) -> return $ Just [whamlet|
|
|
|
|
|
<ul>
|
|
|
|
|
$forall p <- pns
|
|
|
|
|
$forall p <- pns
|
|
|
|
|
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|
|
|
|
|
|]
|
|
|
|
|
mbStatus <- formResultMaybe sresult procFormStatus
|
|
|
|
|
@ -182,7 +183,7 @@ postAdminAvsR = do
|
|
|
|
|
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
|
|
|
|
Right (AvsResponseContact pns) -> return $ Just [whamlet|
|
|
|
|
|
<ul>
|
|
|
|
|
$forall AvsDataContact{..} <- pns
|
|
|
|
|
$forall AvsDataContact{..} <- pns
|
|
|
|
|
<li>
|
|
|
|
|
<ul>
|
|
|
|
|
<li>AvsId: #{tshow avsContactPersonID}
|
|
|
|
|
@ -242,7 +243,7 @@ postAdminAvsR = do
|
|
|
|
|
((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
|
|
|
|
|
flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
|
|
|
|
|
<*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
|
|
|
|
|
let procFormSetLic (aid, lic) = do
|
|
|
|
|
let procFormSetLic (aid, lic) = do
|
|
|
|
|
res <- try $ setLicenceAvs (AvsPersonId aid) lic
|
|
|
|
|
case res of
|
|
|
|
|
(Right True) ->
|
|
|
|
|
@ -327,7 +328,7 @@ instance Finite ButtonAvsImportUnknown
|
|
|
|
|
nullaryPathPiece ''ButtonAvsImportUnknown camelToPathPiece
|
|
|
|
|
embedRenderMessage ''UniWorX ''ButtonAvsImportUnknown id
|
|
|
|
|
instance Button UniWorX ButtonAvsImportUnknown where
|
|
|
|
|
btnClasses BtnAvsImportUnknown = [BCIsButton, BCPrimary]
|
|
|
|
|
btnClasses BtnAvsImportUnknown = [BCIsButton, BCPrimary]
|
|
|
|
|
|
|
|
|
|
data ButtonAvsRevokeUnknown = BtnAvsRevokeUnknown
|
|
|
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic)
|
|
|
|
|
@ -349,12 +350,12 @@ nullaryPathPiece ''LicenceTableAction $ camelToPathPiece' 2
|
|
|
|
|
embedRenderMessage ''UniWorX ''LicenceTableAction id
|
|
|
|
|
|
|
|
|
|
data LicenceTableActionData = LicenceTableChangeAvsData
|
|
|
|
|
| LicenceTableRevokeFDriveData
|
|
|
|
|
| LicenceTableRevokeFDriveData
|
|
|
|
|
{ licenceTableChangeFDriveQId :: QualificationId
|
|
|
|
|
, licenceTableChangeFDriveReason :: Text
|
|
|
|
|
, licenceTableChangeFDriveNotify :: Bool
|
|
|
|
|
}
|
|
|
|
|
| LicenceTableGrantFDriveData
|
|
|
|
|
| LicenceTableGrantFDriveData
|
|
|
|
|
{ licenceTableChangeFDriveQId :: QualificationId
|
|
|
|
|
, licenceTableChangeFDriveReason :: Text
|
|
|
|
|
, licenceTableChangeFDriveEnd :: Day
|
|
|
|
|
@ -365,12 +366,12 @@ data LicenceTableActionData = LicenceTableChangeAvsData
|
|
|
|
|
|
|
|
|
|
postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html
|
|
|
|
|
postProblemAvsSynchR = getProblemAvsSynchR
|
|
|
|
|
getProblemAvsSynchR = do
|
|
|
|
|
getProblemAvsSynchR = do
|
|
|
|
|
let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r)
|
|
|
|
|
catchAllAvs = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload; do not call redirect within catchAllAvs actions!
|
|
|
|
|
(AvsLicenceDifferences{..}, apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
|
|
|
|
|
|
|
|
|
|
--
|
|
|
|
|
--
|
|
|
|
|
unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros ->
|
|
|
|
|
runDB $ E.select $ do
|
|
|
|
|
(toZero :& usrAvs) <- X.from $
|
|
|
|
|
@ -382,7 +383,7 @@ getProblemAvsSynchR = do
|
|
|
|
|
numUnknownLicenceOwners = length unknownLicenceOwners
|
|
|
|
|
|
|
|
|
|
(btnImportUnknownWgt, btnImportUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsImportUnknown
|
|
|
|
|
ifMaybeM btnImportUnknownRes () $ \BtnAvsImportUnknown -> do
|
|
|
|
|
ifMaybeM btnImportUnknownRes () $ \BtnAvsImportUnknown -> do
|
|
|
|
|
res <- catchAllAvs $ forM (take 500 unknownLicenceOwners) $ try . upsertAvsUserById -- TODO: turn this into a background job
|
|
|
|
|
let procRes (Right _) = (Sum 1, mempty :: Set.Set AvsPersonId, mempty :: Set.Set AvsPersonId, mempty)
|
|
|
|
|
--TODO: continue here!
|
|
|
|
|
@ -390,7 +391,7 @@ getProblemAvsSynchR = do
|
|
|
|
|
--procRes (Left (AvsUserUnknownByAvs api)) = (Sum 0, mempty, Set.singleton api, mempty)
|
|
|
|
|
procRes (Left (err :: SomeException)) = (Sum 0, mempty, mempty, Set.singleton $ tshow err)
|
|
|
|
|
(Sum oks, ambis, unkns, errs) = foldMap procRes res
|
|
|
|
|
ms = if oks == numUnknownLicenceOwners then Success else Warning
|
|
|
|
|
ms = if oks == numUnknownLicenceOwners then Success else Warning
|
|
|
|
|
unless (null ambis) $ addMessageModal Error (i18n $ MsgAvsImportAmbiguous $ length ambis) (Right (text2widget $ tshow ambis))
|
|
|
|
|
unless (null unkns) $ addMessageModal Error (i18n $ MsgAvsImportUnknowns $ length unkns) (Right (text2widget $ tshow unkns))
|
|
|
|
|
unless (null errs) $ addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow errs ))
|
|
|
|
|
@ -399,12 +400,12 @@ getProblemAvsSynchR = do
|
|
|
|
|
|
|
|
|
|
(btnRevokeUnknownWgt, btnRevokeUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsRevokeUnknown
|
|
|
|
|
let revokeUnknownExecWgt = btnRevokeUnknownWgt
|
|
|
|
|
revokeUnknownSafetyWgt = [whamlet|
|
|
|
|
|
revokeUnknownSafetyWgt = [whamlet|
|
|
|
|
|
<div .form-group >
|
|
|
|
|
<div .form-group__input>
|
|
|
|
|
<div .buttongroup>
|
|
|
|
|
^{modalBtn}
|
|
|
|
|
|]
|
|
|
|
|
|]
|
|
|
|
|
modalBtn = btnModal MsgBtnAvsRevokeUnknown (btnClasses BtnAvsRevokeUnknown) (Right youSureWgt)
|
|
|
|
|
youSureWgt = [whamlet|
|
|
|
|
|
<h1>
|
|
|
|
|
@ -412,71 +413,71 @@ getProblemAvsSynchR = do
|
|
|
|
|
<p>
|
|
|
|
|
^{revokeUnknownExecWgt}
|
|
|
|
|
|]
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
ifMaybeM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> do
|
|
|
|
|
let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners
|
|
|
|
|
no_revokes = Set.size revokes
|
|
|
|
|
oks <- catchAllAvs $ setLicencesAvs revokes
|
|
|
|
|
if oks < no_revokes
|
|
|
|
|
if oks < no_revokes
|
|
|
|
|
then addMessageI Error MsgRevokeUnknownLicencesFail
|
|
|
|
|
else addMessageI Info MsgRevokeUnknownLicencesOk
|
|
|
|
|
redirect ProblemAvsSynchR
|
|
|
|
|
else addMessageI Info MsgRevokeUnknownLicencesOk
|
|
|
|
|
redirect ProblemAvsSynchR
|
|
|
|
|
|
|
|
|
|
-- licence differences
|
|
|
|
|
((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,)
|
|
|
|
|
<$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll
|
|
|
|
|
<*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld
|
|
|
|
|
<*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld
|
|
|
|
|
<*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
|
|
|
|
|
|
|
|
|
|
((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,)
|
|
|
|
|
<$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll
|
|
|
|
|
<*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld
|
|
|
|
|
<*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld
|
|
|
|
|
<*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
|
|
|
|
|
|
|
|
|
|
now <- liftIO getCurrentTime
|
|
|
|
|
let nowaday = utctDay now
|
|
|
|
|
let nowaday = utctDay now
|
|
|
|
|
procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
|
|
|
|
|
procRes aLic (LicenceTableChangeAvsData , apids) = do
|
|
|
|
|
procRes aLic (LicenceTableChangeAvsData , apids) = do
|
|
|
|
|
oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
|
|
|
|
|
let no_req = Set.size apids
|
|
|
|
|
mkind = if oks < no_req || no_req < 0 then Warning else Success
|
|
|
|
|
addMessageI mkind $ MsgAvsSetLicences aLic oks no_req
|
|
|
|
|
addMessageI mkind $ MsgAvsSetLicences aLic oks no_req
|
|
|
|
|
redirect ProblemAvsSynchR -- reload to update all tables
|
|
|
|
|
|
|
|
|
|
procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do
|
|
|
|
|
procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do
|
|
|
|
|
oks <- runDB $ do
|
|
|
|
|
qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic
|
|
|
|
|
if qId /= licenceTableChangeFDriveQId
|
|
|
|
|
if qId /= licenceTableChangeFDriveQId
|
|
|
|
|
then return (-1)
|
|
|
|
|
else do
|
|
|
|
|
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
|
|
|
|
|
qualificationUserBlocking licenceTableChangeFDriveQId uids False Nothing (Left licenceTableChangeFDriveReason) licenceTableChangeFDriveNotify
|
|
|
|
|
qualificationUserBlocking licenceTableChangeFDriveQId uids False Nothing (Left licenceTableChangeFDriveReason) licenceTableChangeFDriveNotify
|
|
|
|
|
if | oks < 0 -> addMessageI Error $ MsgRevokeFraDriveLicencesError alic
|
|
|
|
|
| oks > 0, oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences alic oks
|
|
|
|
|
| otherwise -> addMessageI Warning $ MsgRevokeFraDriveLicences alic oks
|
|
|
|
|
redirect ProblemAvsSynchR -- must be outside runDB
|
|
|
|
|
redirect ProblemAvsSynchR -- must be outside runDB
|
|
|
|
|
|
|
|
|
|
procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do
|
|
|
|
|
(n, Qualification{qualificationShorthand}) <- runDB $ do
|
|
|
|
|
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
|
|
|
|
|
(n, Qualification{qualificationShorthand}) <- runDB $ do
|
|
|
|
|
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
|
|
|
|
|
-- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
|
|
|
|
|
void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True Nothing (Left licenceTableChangeFDriveReason) False
|
|
|
|
|
forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
|
|
|
|
|
(length uids,) <$> get404 licenceTableChangeFDriveQId
|
|
|
|
|
addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
|
|
|
|
|
redirect ProblemAvsSynchR -- must be outside runDB
|
|
|
|
|
|
|
|
|
|
redirect ProblemAvsSynchR -- must be outside runDB
|
|
|
|
|
|
|
|
|
|
formResult tres2 $ procRes AvsLicenceRollfeld
|
|
|
|
|
formResult tres1down $ procRes AvsLicenceVorfeld
|
|
|
|
|
formResult tres1up $ procRes AvsLicenceVorfeld
|
|
|
|
|
formResult tres1up $ procRes AvsLicenceVorfeld
|
|
|
|
|
formResult tres0 $ procRes AvsNoLicence
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
siteLayoutMsg MsgAvsTitleLicenceSynch $ do
|
|
|
|
|
setTitleI MsgAvsTitleLicenceSynch
|
|
|
|
|
$(i18nWidgetFile "avs-synchronisation")
|
|
|
|
|
|
|
|
|
|
type LicenceTableExpr = ( E.SqlExpr (Entity UserAvs)
|
|
|
|
|
`E.InnerJoin` E.SqlExpr (Entity User)
|
|
|
|
|
type LicenceTableExpr = ( E.SqlExpr (Entity UserAvs)
|
|
|
|
|
`E.InnerJoin` E.SqlExpr (Entity User)
|
|
|
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUser))
|
|
|
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Qualification))
|
|
|
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
|
|
|
|
)
|
|
|
|
|
)
|
|
|
|
|
|
|
|
|
|
queryUserAvs :: LicenceTableExpr -> E.SqlExpr (Entity UserAvs)
|
|
|
|
|
queryUserAvs = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 4 1)
|
|
|
|
|
@ -495,13 +496,13 @@ queryQualBlock = $(E.sqlLOJproj 4 4)
|
|
|
|
|
|
|
|
|
|
type LicenceTableData = DBRow (Entity UserAvs, Entity User, Maybe (Entity QualificationUser), Maybe (Entity Qualification), Maybe (Entity QualificationUserBlock))
|
|
|
|
|
|
|
|
|
|
resultUserAvs :: Lens' LicenceTableData (Entity UserAvs)
|
|
|
|
|
resultUserAvs :: Lens' LicenceTableData (Entity UserAvs)
|
|
|
|
|
resultUserAvs = _dbrOutput . _1
|
|
|
|
|
|
|
|
|
|
resultUser :: Lens' LicenceTableData (Entity User)
|
|
|
|
|
resultUser :: Lens' LicenceTableData (Entity User)
|
|
|
|
|
resultUser = _dbrOutput . _2
|
|
|
|
|
|
|
|
|
|
resultQualUser :: Traversal' LicenceTableData (Entity QualificationUser)
|
|
|
|
|
resultQualUser :: Traversal' LicenceTableData (Entity QualificationUser)
|
|
|
|
|
resultQualUser = _dbrOutput . _3 . _Just
|
|
|
|
|
|
|
|
|
|
resultQualification :: Traversal' LicenceTableData (Entity Qualification)
|
|
|
|
|
@ -510,46 +511,46 @@ resultQualification = _dbrOutput . _4 . _Just
|
|
|
|
|
resultQualBlock :: Traversal' LicenceTableData (Entity QualificationUserBlock)
|
|
|
|
|
resultQualBlock = _dbrOutput . _5 . _Just
|
|
|
|
|
|
|
|
|
|
instance HasEntity LicenceTableData User where
|
|
|
|
|
instance HasEntity LicenceTableData User where
|
|
|
|
|
hasEntity = resultUser
|
|
|
|
|
|
|
|
|
|
instance HasUser LicenceTableData where
|
|
|
|
|
instance HasUser LicenceTableData where
|
|
|
|
|
hasUser = resultUser . _entityVal
|
|
|
|
|
|
|
|
|
|
-- instance HasQualificationUser LicenceTableData where -- Not possible, since not all rows have a QualificationUser
|
|
|
|
|
-- hasQualificationUser = resultQualUser . _entityVal
|
|
|
|
|
|
|
|
|
|
mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
|
|
|
|
|
mkLicenceTable apidStatus dbtIdent aLic apids = do
|
|
|
|
|
mkLicenceTable apidStatus dbtIdent aLic apids = do
|
|
|
|
|
currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
|
|
|
|
|
avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] []
|
|
|
|
|
now <- liftIO getCurrentTime
|
|
|
|
|
|
|
|
|
|
let nowaday = utctDay now
|
|
|
|
|
|
|
|
|
|
let nowaday = utctDay now
|
|
|
|
|
avsQids = entityKey <$> avsQualifications
|
|
|
|
|
-- fltrLic qual = if
|
|
|
|
|
-- fltrLic qual = if
|
|
|
|
|
-- | aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence) -- could be R, F, both or none at all, but has licence in AVS
|
|
|
|
|
-- | otherwise -> E.isNothing (qual E.?. QualificationId) E.||. (E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence)) -- if we suggest granting that licence, this join should deliver a value too
|
|
|
|
|
fltrLic qual = E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence)
|
|
|
|
|
-- TODO: user holding multiple qualifications may appear multiple times in to-delete-in-avs table, which is kinda ugly. Solution:
|
|
|
|
|
-- TODO: user holding multiple qualifications may appear multiple times in to-delete-in-avs table, which is kinda ugly. Solution:
|
|
|
|
|
dbtSQLQuery = \(usrAvs `E.InnerJoin` user `E.LeftOuterJoin` qualUser `E.LeftOuterJoin` qual `E.LeftOuterJoin` qblock) -> do
|
|
|
|
|
E.on $ qblock E.?. QualificationUserBlockQualificationUser E.==. qualUser E.?. QualificationUserId
|
|
|
|
|
E.&&. qblock `isLatestBlockBefore` E.val now
|
|
|
|
|
E.on $ qual E.?. QualificationId E.==. qualUser E.?. QualificationUserQualification
|
|
|
|
|
E.on $ user E.^. UserId E.=?. qualUser E.?. QualificationUserUser
|
|
|
|
|
E.on $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser
|
|
|
|
|
E.where_ $ fltrLic qual
|
|
|
|
|
E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids)
|
|
|
|
|
E.where_ $ fltrLic qual
|
|
|
|
|
E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids)
|
|
|
|
|
return (usrAvs, user, qualUser, qual, qblock)
|
|
|
|
|
dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR?
|
|
|
|
|
-- Not sure what changes here:
|
|
|
|
|
dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali)
|
|
|
|
|
dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali)
|
|
|
|
|
dbtColonnade = mconcat
|
|
|
|
|
[ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId)
|
|
|
|
|
-- (\DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID) -- does not type due to traversal
|
|
|
|
|
, colUserNameLink AdminUserR
|
|
|
|
|
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a
|
|
|
|
|
-- , colUserCompany
|
|
|
|
|
-- , colUserCompany
|
|
|
|
|
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
|
|
|
|
|
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
|
|
|
|
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
|
|
|
|
@ -573,7 +574,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
|
|
|
|
, sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus
|
|
|
|
|
]
|
|
|
|
|
dbtSorting = mconcat
|
|
|
|
|
[ single $ sortUserNameLink queryUser
|
|
|
|
|
[ single $ sortUserNameLink queryUser
|
|
|
|
|
, single ("avspersonno" , SortColumn $ queryUserAvs >>> (E.^. UserAvsNoPerson))
|
|
|
|
|
, single ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand))
|
|
|
|
|
, single $ sortUserCompany queryUser
|
|
|
|
|
@ -588,22 +589,22 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
|
|
|
|
dbtFilter = mconcat
|
|
|
|
|
[ single $ fltrUserNameEmail queryUser
|
|
|
|
|
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now))
|
|
|
|
|
, single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
|
|
|
|
|
E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
|
|
|
|
, single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
|
|
|
|
|
E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
|
|
|
|
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
|
|
|
|
|
(E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
|
|
|
|
|
testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
|
|
|
|
|
testcrit = maybe testname testnumber $ readMay $ CI.original criterion
|
|
|
|
|
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
|
|
|
|
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
|
|
|
|
|
)
|
|
|
|
|
)
|
|
|
|
|
]
|
|
|
|
|
dbtFilterUI mPrev = mconcat
|
|
|
|
|
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
|
|
|
|
|
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
|
|
|
|
|
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
|
|
|
|
|
]
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
qualOpt :: Entity Qualification -> Handler (Option QualificationId)
|
|
|
|
|
qualOpt (Entity qualId qual) = do
|
|
|
|
|
cQualId :: CryptoUUIDQualification <- encrypt qualId
|
|
|
|
|
@ -611,17 +612,17 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
|
|
|
|
{ optionDisplay = CI.original $ qualificationName qual
|
|
|
|
|
, optionInternalValue = qualId
|
|
|
|
|
, optionExternalValue = tshow cQualId
|
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications
|
|
|
|
|
|
|
|
|
|
-- Block identical to Handler/Qualifications TODO: refactor
|
|
|
|
|
getBlockReasons unblk = E.select $ do
|
|
|
|
|
(quser :& qblock) <- X.from $ E.table @QualificationUser
|
|
|
|
|
getBlockReasons unblk = E.select $ do
|
|
|
|
|
(quser :& qblock) <- X.from $ E.table @QualificationUser
|
|
|
|
|
`E.innerJoin` E.table @QualificationUserBlock
|
|
|
|
|
`X.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser)
|
|
|
|
|
E.where_ $ ((quser E.^. QualificationUserQualification) `E.in_` E.valList avsQids)
|
|
|
|
|
E.&&. unblk (qblock E.^. QualificationUserBlockUnblock)
|
|
|
|
|
E.groupBy (qblock E.^. QualificationUserBlockReason)
|
|
|
|
|
E.groupBy (qblock E.^. QualificationUserBlockReason)
|
|
|
|
|
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
|
|
|
|
|
E.orderBy [E.desc countRows']
|
|
|
|
|
E.limit 7
|
|
|
|
|
@ -641,12 +642,12 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
|
|
|
|
<*> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
|
|
|
|
|
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
|
|
|
|
|
|
|
|
|
|
else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData
|
|
|
|
|
else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData
|
|
|
|
|
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
|
|
|
|
|
<*> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing
|
|
|
|
|
<*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?!
|
|
|
|
|
<*> aopt (convertField not not (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgQualificationUserNoRenewal) Nothing
|
|
|
|
|
]
|
|
|
|
|
]
|
|
|
|
|
dbtParams = DBParamsForm
|
|
|
|
|
{ dbParamsFormMethod = POST
|
|
|
|
|
, dbParamsFormAction = Just $ SomeRoute currentRoute
|
|
|
|
|
@ -663,11 +664,11 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
|
|
|
|
dbtCsvEncode = noCsvEncode
|
|
|
|
|
dbtCsvDecode = Nothing
|
|
|
|
|
dbtExtraReps = []
|
|
|
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
|
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
|
|
|
validator = def & defaultSorting [SortAscBy "user-name"]
|
|
|
|
|
postprocess :: FormResult (First LicenceTableActionData, DBFormResult AvsPersonId Bool LicenceTableData) -- == DBFormResult (Map AvsPersonId (LicenceTableData, Bool -> Bool))
|
|
|
|
|
-> FormResult ( LicenceTableActionData, Set AvsPersonId)
|
|
|
|
|
postprocess inp = do
|
|
|
|
|
postprocess inp = do
|
|
|
|
|
(First (Just act), usrMap) <- inp
|
|
|
|
|
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
|
|
|
|
return (act, usrSet)
|
|
|
|
|
@ -679,17 +680,17 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
|
|
|
|
getAdminAvsUserR :: CryptoUUIDUser -> Handler Html
|
|
|
|
|
getAdminAvsUserR uuid = do
|
|
|
|
|
uid <- decrypt uuid
|
|
|
|
|
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
|
|
|
|
|
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
|
|
|
|
|
mAvsQuery <- getsYesod $ view _appAvsQuery
|
|
|
|
|
resWgt <- case mAvsQuery of
|
|
|
|
|
Nothing -> return [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
|
|
|
|
|
Just AvsQuery{..} -> do
|
|
|
|
|
Just AvsQuery{..} -> do
|
|
|
|
|
mbContact <- avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
|
|
|
|
|
mbDataPerson <- lookupAvsUser userAvsPersonId
|
|
|
|
|
mbDataPerson <- lookupAvsUser userAvsPersonId
|
|
|
|
|
return [whamlet|
|
|
|
|
|
<p>
|
|
|
|
|
Vorläufige Admin Ansicht AVS Daten.
|
|
|
|
|
Ansicht zeigt aktuelle Daten.
|
|
|
|
|
Vorläufige Admin Ansicht AVS Daten.
|
|
|
|
|
Ansicht zeigt aktuelle Daten.
|
|
|
|
|
Es erfolgte damit aber noch kein Update der FRADrive Daten.
|
|
|
|
|
<p>
|
|
|
|
|
<dl .deflist>
|
|
|
|
|
@ -697,28 +698,94 @@ getAdminAvsUserR uuid = do
|
|
|
|
|
<i>(bevorzugt)
|
|
|
|
|
<dd .deflist__dd>
|
|
|
|
|
$case mbContact
|
|
|
|
|
$of Left err
|
|
|
|
|
$of Left err
|
|
|
|
|
Fehler: #{tshow err}
|
|
|
|
|
$of Right contactInfo
|
|
|
|
|
#{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
|
|
|
|
|
#{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
|
|
|
|
|
<dt .deflist__dt>PersonStatus und mehrere PersonSearch <br>
|
|
|
|
|
<i>(benötigt mehrere AVS Abfragen)
|
|
|
|
|
<dd .deflist__dd>
|
|
|
|
|
$maybe dataPerson <- mbDataPerson
|
|
|
|
|
#{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
|
|
|
|
|
$nothing
|
|
|
|
|
Keine Daten erhalten.
|
|
|
|
|
$nothing
|
|
|
|
|
Keine Daten erhalten.
|
|
|
|
|
<h3>
|
|
|
|
|
Provisorische formatierte Ansicht
|
|
|
|
|
<p>
|
|
|
|
|
Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte.
|
|
|
|
|
<p>
|
|
|
|
|
Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte.
|
|
|
|
|
In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar.
|
|
|
|
|
<p>
|
|
|
|
|
<p>
|
|
|
|
|
^{foldMap jsonWidget mbContact}
|
|
|
|
|
<p>
|
|
|
|
|
<p>
|
|
|
|
|
^{foldMap jsonWidget mbDataPerson}
|
|
|
|
|
|]
|
|
|
|
|
|]
|
|
|
|
|
let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
|
|
|
|
|
siteLayout heading $ do
|
|
|
|
|
siteLayout heading $ do
|
|
|
|
|
setTitle $ toHtml $ show userAvsNoPerson
|
|
|
|
|
resWgt
|
|
|
|
|
|
|
|
|
|
instance HasEntity (DBRow (Entity UserAvs, Entity User)) User where
|
|
|
|
|
hasEntity = _dbrOutput . _2
|
|
|
|
|
|
|
|
|
|
instance HasUser (DBRow (Entity UserAvs, Entity User)) where
|
|
|
|
|
hasUser = _dbrOutput . _2 . _entityVal
|
|
|
|
|
|
|
|
|
|
getProblemAvsErrorR :: Handler Html
|
|
|
|
|
getProblemAvsErrorR = do
|
|
|
|
|
let
|
|
|
|
|
avsSyncErrDBTable = DBTable{..}
|
|
|
|
|
where
|
|
|
|
|
dbtIdent :: Text
|
|
|
|
|
dbtIdent = "avs-errors"
|
|
|
|
|
dbtSQLQuery (usravs `E.InnerJoin` user) = do
|
|
|
|
|
E.on $ usravs E.^. UserAvsUser E.==. user E.^. UserId
|
|
|
|
|
E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError
|
|
|
|
|
return (usravs, user)
|
|
|
|
|
qerryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs)
|
|
|
|
|
qerryUsrAvs = $(E.sqlIJproj 2 1)
|
|
|
|
|
qerryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
|
|
|
|
|
qerryUser = $(E.sqlIJproj 2 2)
|
|
|
|
|
reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs)
|
|
|
|
|
reserrUsrAvs = _dbrOutput . _1
|
|
|
|
|
-- reserrUser :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User)
|
|
|
|
|
-- reserrUser = _dbrOutput . _2
|
|
|
|
|
dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId)
|
|
|
|
|
dbtProj = dbtProjId
|
|
|
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
|
|
|
[ colUserNameModalHdr MsgLmsUser AdminUserR
|
|
|
|
|
, sortable (Just "avs-nr") (i18nCell MsgAvsPersonNo)
|
|
|
|
|
$ avsPersonNoLinkedCell . view reserrUsrAvs
|
|
|
|
|
, sortable Nothing (i18nCell MsgAvsPersonId)
|
|
|
|
|
$ numCell . view (reserrUsrAvs . _entityVal . _userAvsPersonId . _AvsPersonId)
|
|
|
|
|
, sortable (Just "avs-last-synch") (i18nCell MsgLastAvsSynchronisation)
|
|
|
|
|
$ dateTimeCell . view (reserrUsrAvs . _entityVal . _userAvsLastSynch)
|
|
|
|
|
, sortable (Just "avs-last-error") (i18nCell MsgLastAvsSynchError)
|
|
|
|
|
$ cellMaybe textCell . view (reserrUsrAvs . _entityVal . _userAvsLastSynchError)
|
|
|
|
|
]
|
|
|
|
|
dbtSorting = mconcat
|
|
|
|
|
[ single (sortUserNameLink qerryUser)
|
|
|
|
|
, single ("avs-nr" , SortColumn $ qerryUsrAvs >>> (E.^. UserAvsNoPerson))
|
|
|
|
|
, single ("avs-last-synch", SortColumnNullsInv $ qerryUsrAvs >>> (E.^. UserAvsLastSynch))
|
|
|
|
|
, single ("avs-last-error", SortColumn $ qerryUsrAvs >>> (E.^. UserAvsLastSynchError))
|
|
|
|
|
]
|
|
|
|
|
dbtFilter = mconcat
|
|
|
|
|
[ single $ fltrUserNameEmail qerryUser
|
|
|
|
|
, single ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to qerryUsrAvs) (E.^. UserAvsLastSynchError))
|
|
|
|
|
]
|
|
|
|
|
dbtFilterUI mPrev = mconcat
|
|
|
|
|
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
|
|
|
|
|
, prismAForm (singletonFilter "avs-last-error" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgLastAvsSynchError)
|
|
|
|
|
]
|
|
|
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
|
|
|
dbtParams = def
|
|
|
|
|
dbtCsvEncode = Nothing
|
|
|
|
|
dbtCsvDecode = Nothing
|
|
|
|
|
dbtExtraReps = []
|
|
|
|
|
avsSyncErrDBTableValidator = def & defaultSorting [SortDescBy "avs-last-synch"]
|
|
|
|
|
mkAvsSynchErrorTable :: DB (Any, Widget)
|
|
|
|
|
mkAvsSynchErrorTable = dbTable avsSyncErrDBTableValidator avsSyncErrDBTable
|
|
|
|
|
avsSyncErrTbl <- runDB (snd <$> mkAvsSynchErrorTable)
|
|
|
|
|
siteLayoutMsg MsgMenuAvsSynchError $ do
|
|
|
|
|
setTitleI MsgMenuAvsSynchError
|
|
|
|
|
[whamlet|^{avsSyncErrTbl}|]
|
|
|
|
|
|
