Steffen Jost
ab340aa715
AVSneo will no longer have unique AVS CardNo: PersonSearch will return one card per company, all having the same CardNo, but possibly different colors Test shows that FRADrive will handle this just fine, provided the old AVS workaround firing several requests at once remain in place
1049 lines
58 KiB
Haskell
1049 lines
58 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
|
{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Handler.Admin.Avs
|
|
( getAdminAvsR, postAdminAvsR
|
|
, getAdminAvsUserR, postAdminAvsUserR
|
|
, getProblemAvsSynchR, postProblemAvsSynchR
|
|
, getProblemAvsErrorR
|
|
) where
|
|
|
|
import Import
|
|
import qualified Control.Monad.State.Class as State
|
|
-- import Data.Aeson (encode)
|
|
-- import qualified Data.Aeson.Encode.Pretty as Pretty
|
|
import qualified Data.Text as Text
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
-- import Database.Persist.Sql (updateWhereCount)
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Avs
|
|
-- import Handler.Utils.Qualification
|
|
import Handler.Utils.Users (getUserPrimaryCompany)
|
|
import Handler.Utils.Company (switchAvsUserCompany)
|
|
|
|
import Database.Esqueleto.Experimental ((:&)(..))
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Experimental as E hiding (from, on)
|
|
import qualified Database.Esqueleto.Experimental as X (from, on) -- needs TypeApplications Lang-Pragma
|
|
import qualified Database.Esqueleto.Utils as E
|
|
-- import Database.Esqueleto.Utils.TH
|
|
|
|
|
|
exceptionWgt :: SomeException -> Widget
|
|
exceptionWgt (SomeException e) = [whamlet|<h2>Error:</h2> #{tshow e}|]
|
|
|
|
tryShow :: MonadCatch m => m Widget -> m Widget
|
|
tryShow act = try act >>= \case
|
|
Left err -> return $ exceptionWgt err
|
|
Right res -> return res
|
|
|
|
-- Button only needed in AVS TEST; further buttons see below
|
|
data ButtonAvsTest = BtnCheckLicences -- | BtnSynchLicences
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic)
|
|
instance Universe ButtonAvsTest
|
|
instance Finite ButtonAvsTest
|
|
|
|
nullaryPathPiece ''ButtonAvsTest camelToPathPiece
|
|
|
|
instance Button UniWorX ButtonAvsTest where
|
|
btnLabel BtnCheckLicences = "Show all licence difference to current AVS" -- could be msg
|
|
-- btnLabel BtnSynchLicences = "Synchronize all licences" -- could be msg
|
|
btnClasses BtnCheckLicences = [BCIsButton, BCPrimary]
|
|
-- btnClasses BtnSynchLicences = [BCIsButton, BCDanger]
|
|
-- END Button
|
|
|
|
|
|
avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsCardNo
|
|
avsCardNoField = convertField AvsCardNo avsCardNo textField
|
|
|
|
avsInternalPersonalNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsInternalPersonalNo
|
|
avsInternalPersonalNoField = convertField mkAvsInternalPersonalNo avsInternalPersonalNo textField
|
|
|
|
makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson
|
|
makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html ->
|
|
flip (renderAForm FormStandard) html $ AvsQueryPerson
|
|
<$> aopt avsCardNoField (fslI MsgAvsCardNo) (avsPersonQueryCardNo <$> tmpl)
|
|
<*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl)
|
|
<*> aopt textField (fslI MsgAvsFirstName) (avsPersonQueryFirstName <$> tmpl)
|
|
<*> aopt textField (fslI MsgAvsLastName) (avsPersonQueryLastName <$> tmpl)
|
|
<*> aopt avsInternalPersonalNoField
|
|
(fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl)
|
|
|
|
|
|
validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler ()
|
|
validateAvsQueryPerson = do
|
|
AvsQueryPerson{..} <- State.get
|
|
guardValidation MsgAvsQueryEmpty $
|
|
is _Just avsPersonQueryCardNo ||
|
|
is _Just avsPersonQueryFirstName ||
|
|
is _Just avsPersonQueryLastName ||
|
|
is _Just avsPersonQueryInternalPersonalNo ||
|
|
is _Just avsPersonQueryVersionNo
|
|
|
|
makeAvsStatusForm :: Maybe AvsPersonId -> Form AvsQueryStatus
|
|
makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html ->
|
|
flip (renderAForm FormStandard) html $
|
|
parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl)
|
|
where
|
|
parseAvsIds :: Text -> AvsQueryStatus
|
|
parseAvsIds txt = AvsQueryStatus $ Set.fromList ids
|
|
where
|
|
nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
|
|
ids = mapMaybe readMay nonemptys
|
|
unparseAvsIds :: AvsPersonId -> Text
|
|
unparseAvsIds = tshow . avsPersonId
|
|
|
|
validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler ()
|
|
validateAvsQueryStatus = do
|
|
AvsQueryStatus ids <- State.get
|
|
guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
|
|
|
|
makeAvsContactForm :: Maybe AvsPersonId -> Form AvsQueryContact
|
|
makeAvsContactForm tmpl = identifyForm FIDAvsQueryContact . validateForm validateAvsQueryContact $ \html ->
|
|
flip (renderAForm FormStandard) html $
|
|
parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl) -- consider using cfAnySeparatedSet here
|
|
where
|
|
parseAvsIds :: Text -> AvsQueryContact
|
|
parseAvsIds txt = AvsQueryContact $ Set.fromList ids
|
|
where
|
|
nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
|
|
ids = mapMaybe (fmap AvsObjPersonId . readMay) nonemptys
|
|
unparseAvsIds :: AvsPersonId -> Text
|
|
unparseAvsIds = tshow . avsPersonId
|
|
--unparseAvsIds (AvsQueryContact ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
|
|
|
|
validateAvsQueryContact :: FormValidator AvsQueryContact Handler ()
|
|
validateAvsQueryContact = do
|
|
AvsQueryContact ids <- State.get
|
|
guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
|
|
|
|
|
|
avsLicenceOptions :: OptionList AvsLicence
|
|
avsLicenceOptions = mkOptionList
|
|
[ Option
|
|
{ optionDisplay = Text.singleton $ licence2char l
|
|
, optionInternalValue = l
|
|
, optionExternalValue = toJsonText l
|
|
}
|
|
| l <- universeF
|
|
]
|
|
|
|
getAdminAvsR, postAdminAvsR :: Handler Html
|
|
getAdminAvsR = postAdminAvsR
|
|
postAdminAvsR = do
|
|
mbAvsConf <- getsYesod $ view _appAvsConf
|
|
let avsWgt = [whamlet|
|
|
$maybe avsConf <- mbAvsConf
|
|
<h2>
|
|
AVS Konfiguration
|
|
<ul>
|
|
<li>
|
|
Host: #{decodeUtf8 (avsUser avsConf)}@#{avsHost avsConf}:#{avsPort avsConf}
|
|
<li>
|
|
Timeout sekundäre AVS Abfragen: #{avsTimeout avsConf}s
|
|
<li>
|
|
Cache Gültigkeit sekundäre AVS Abfragen: #{tshow (avsCacheExpiry avsConf)}
|
|
$nothing
|
|
AVS nicht konfiguriert!
|
|
|]
|
|
|
|
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
|
|
|
|
let procFormPerson :: AvsQueryPerson -> Handler (Maybe (Maybe Widget, Maybe AvsPersonId))
|
|
procFormPerson (fixAvsQueryPerson -> fr) = do
|
|
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
|
|
try (avsQuery fr) >>= \case
|
|
Left err -> return $ Just (Just $ exceptionWgt err, Nothing)
|
|
Right (AvsResponsePerson pns) -> do
|
|
let mapid = case Set.toList pns of
|
|
[AvsDataPerson{avsPersonPersonID=apid}] -> Just apid
|
|
_ -> Nothing
|
|
wgt = [whamlet|
|
|
<ul>
|
|
$forall p <- pns
|
|
<li>^{jsonWidget p}
|
|
|] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|
|
return $ Just (toMaybe (notNull pns) wgt, mapid)
|
|
(mbPerson,mapid) <- fromMaybe (Nothing,Nothing) <$> formResultMaybe presult procFormPerson
|
|
|
|
((sresult', swidget), senctype) <- runFormPost $ makeAvsStatusForm mapid
|
|
let sresult = sresult' <|> maybe FormMissing (FormSuccess . AvsQueryStatus . Set.singleton) mapid -- use unique AvsId from PersonSearch for convenience, if form was empty
|
|
procFormStatus fr = do
|
|
addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
|
|
tryShow $ do
|
|
AvsResponseStatus pns <- avsQuery fr
|
|
return [whamlet|
|
|
<ul>
|
|
$forall p <- pns
|
|
<li>^{jsonWidget p}
|
|
|]
|
|
mbStatus <- formResultMaybe sresult (Just <<$>> procFormStatus)
|
|
|
|
((cresult', cwidget), cenctype) <- runFormPost $ makeAvsContactForm mapid
|
|
let cresult = cresult' <|> maybe FormMissing (FormSuccess . AvsQueryContact . Set.singleton . AvsObjPersonId) mapid -- use unique AvsId from PersonSearch for convenience, if form was empty
|
|
procFormContact fr = do
|
|
addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
|
|
tryShow $ do
|
|
AvsResponseContact pns <- avsQuery fr
|
|
return [whamlet|
|
|
<ul>
|
|
$forall AvsDataContact{..} <- pns
|
|
<li>
|
|
<ul>
|
|
<li>AvsId: #{tshow avsContactPersonID}
|
|
<li>^{jsonWidget avsContactPersonInfo}
|
|
<li>^{jsonWidget avsContactFirmInfo}
|
|
|] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
|
|
mbContact <- formResultMaybe cresult (Just <<$>> procFormContact)
|
|
|
|
|
|
((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
|
|
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
|
|
let procFormCrUsr fr = do
|
|
-- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
|
|
res <- try $ guessAvsUser fr
|
|
case res of
|
|
(Right (Just uid)) -> do
|
|
uuid :: CryptoUUIDUser <- encrypt uid
|
|
return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
|
|
(Right Nothing) ->
|
|
return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
|
|
(Left e) -> return $ Just $ exceptionWgt e
|
|
mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
|
|
|
|
((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
|
|
flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
|
|
<*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
|
|
<*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
|
|
let procFormGetLic fr = tryShow $ do
|
|
AvsResponseGetLicences lics <- avsQuery AvsQueryGetAllLicences
|
|
let flics = Set.toList $ Set.filter lfltr lics
|
|
lfltr = case fr of -- not pretty, but it'll do
|
|
(Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
|
|
(Just idmin, Nothing, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin)
|
|
(Nothing , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax)
|
|
(Nothing , Nothing, Just lic) -> \AvsPersonLicence{..} -> avsLicenceRampLicence == lic
|
|
(Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID
|
|
(Just idmin, Nothing, Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID
|
|
(Nothing , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID
|
|
(Nothing , Nothing, Nothing ) -> const True
|
|
addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
|
|
return [whamlet|
|
|
<h2>Success:</h2>
|
|
<ul>
|
|
$forall AvsPersonLicence{..} <- flics
|
|
<li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
|
|
|]
|
|
mbGetLic <- formResultMaybe getLicRes (Just <<$>> procFormGetLic)
|
|
|
|
((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
|
|
res <- try $ setLicenceAvs (AvsPersonId aid) lic
|
|
case res of
|
|
(Right True) ->
|
|
return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
|
|
(Right False) ->
|
|
return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
|
|
(Left e) -> do
|
|
let msg = tshow (e :: SomeException)
|
|
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
|
mbSetLic <- formResultMaybe setLicRes procFormSetLic
|
|
|
|
|
|
(qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
|
|
(mbQryLic :: Maybe Widget, mbAutoDiffs :: Maybe Html) <- case qryLicRes of
|
|
Nothing -> return mempty
|
|
(Just BtnCheckLicences) -> do
|
|
res <- try $ do
|
|
allLicences <- avsQueryNoCache AvsQueryGetAllLicences
|
|
computeDifferingLicences allLicences
|
|
basediffs <- case res of
|
|
(Right diffs) -> do
|
|
let showLics l =
|
|
let chgs = Set.filter ((l ==) . avsLicenceRampLicence) diffs
|
|
in if Set.null chgs
|
|
then ("[ ]", 0)
|
|
else (Text.intercalate ", " (tshow . avsLicencePersonID <$> Set.toList chgs), Set.size chgs)
|
|
(r_grant, rg_size) = showLics AvsLicenceRollfeld
|
|
(f_set , fs_size) = showLics AvsLicenceVorfeld
|
|
(revoke , rv_size) = showLics AvsNoLicence
|
|
return $ Just [whamlet|
|
|
<h2>Licence check AVS-ID differences:
|
|
<dl .deflist>
|
|
<dt .deflist__dt>Grant R (#{rg_size}):
|
|
<dd .deflist__dd>#{r_grant}
|
|
|
|
<dt .deflist__dt>Set to F (#{fs_size}):
|
|
<dd .deflist__dd>#{f_set}
|
|
|
|
<dt .deflist__dt>Revoke licence (#{rv_size}):
|
|
<dd .deflist__dd>#{revoke}
|
|
|]
|
|
(Left e) -> do
|
|
let msg = tshow (e :: SomeException)
|
|
return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
|
|
autoDiffs <- do
|
|
-- what follows is copy of the code from Jobs.Handler.SynchroniseAvs.dispatchJobSynchroniseAvsLicences modified to not do anything actually
|
|
AvsLicenceSynchConf
|
|
{ avsLicenceSynchLevel = synchLevel -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F
|
|
, avsLicenceSynchReasonFilter = reasonFilter
|
|
, avsLicenceSynchMaxChanges = maxChanges
|
|
} <- getsYesod $ view _appAvsLicenceSynchConf
|
|
guardMonoidM (synchLevel > 0) $ do
|
|
let showApids apids
|
|
| null apids = "[ ]"
|
|
| otherwise = Text.intercalate ", " (tshow <$> Set.toList apids)
|
|
procLic :: (Ord a, Show a) => AvsLicence -> Bool -> Set a -> Html
|
|
procLic aLic up apids
|
|
| n <- Set.size apids, n > 0 =
|
|
let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
|
|
in if NTop (Just n) <= NTop maxChanges
|
|
then
|
|
[shamlet|
|
|
<dt .deflist__dt>#{subtype} (#{n}):
|
|
<dd .deflist__dd>#{showApids apids}
|
|
|]
|
|
else
|
|
[shamlet|
|
|
<dt .deflist__dt>#{subtype} (#{n}):
|
|
<dd .deflist__dd>Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}
|
|
|]
|
|
| otherwise = mempty
|
|
|
|
(AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
|
|
-- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
|
|
reasonFltrdIds <- ifNothingM reasonFilter mempty $ \reasons -> do
|
|
now <- liftIO getCurrentTime
|
|
firmBlocks <- runDBRead $ E.select $ do
|
|
(uavs :& _qualUser :& qblock) <- X.from $ E.table @UserAvs
|
|
`E.innerJoin` E.table @QualificationUser `X.on` (\( uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser)
|
|
`E.innerJoin` E.table @QualificationUserBlock `X.on` (\(_uavs :& qualUser :& qblock) ->
|
|
qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
|
|
E.&&. qblock `isLatestBlockBefore'` E.val now)
|
|
E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
|
|
E.&&. uavs E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld])
|
|
return $ uavs E.^. UserAvsPersonId
|
|
return $ Set.fromList $ map E.unValue firmBlocks
|
|
|
|
let fltrIds
|
|
| synchLevel >= 5 = id
|
|
| synchLevel >= 3 = flip Set.difference reasonFltrdIds
|
|
| otherwise = flip Set.difference $ reasonFltrdIds `Set.union` rsChanged
|
|
|
|
l1 = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence False $ fltrIds avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld
|
|
l2 = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ fltrIds avsLicenceDiffGrantVorfeld --grant Vorfeld
|
|
l3 = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld False $ fltrIds avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld
|
|
l4 = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True $ fltrIds avsLicenceDiffGrantRollfeld --grant Rollfeld
|
|
avsIdChanges = [shamlet|
|
|
<h3>
|
|
Next automatic AVS-ID licence synchronisation:
|
|
<dl .deflist>
|
|
^{l4}
|
|
^{l3}
|
|
^{l2}
|
|
^{l1}
|
|
$maybe reason <- reasonFilter
|
|
<dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
|
|
<dd .deflist__dd>#{showApids reasonFltrdIds}
|
|
|]
|
|
----------------------------------------------------
|
|
-- translate AVS-IDs to AVS-NOs for convenience only
|
|
avsidnos <- runDBRead $ E.select $ do
|
|
ua <- X.from $ E.table @UserAvs
|
|
E.where_ $ ua E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld]) -- , reasonFltrdIds])
|
|
return (ua E.^. UserAvsPersonId, ua E.^. UserAvsNoPerson)
|
|
let id2no = Map.fromList $ $(E.unValueN 2) <$> avsidnos
|
|
translate = setMapMaybe (`Map.lookup` id2no)
|
|
l1' = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence False $ translate $ fltrIds avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld
|
|
l2' = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ translate $ fltrIds avsLicenceDiffGrantVorfeld --grant Vorfeld
|
|
l3' = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld False $ translate $ fltrIds avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld
|
|
l4' = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True $ translate $ fltrIds avsLicenceDiffGrantRollfeld --grant Rollfeld
|
|
autoNoDiffs = [shamlet|
|
|
<h3>
|
|
Next automatic licence changes translated to human readable AVS-Numbers, if known:
|
|
<dl .deflist>
|
|
^{l4'}
|
|
^{l3'}
|
|
^{l2'}
|
|
^{l1'}
|
|
$maybe reason <- reasonFilter
|
|
<dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
|
|
<dd .deflist__dd>#{showApids $ translate reasonFltrdIds}
|
|
|]
|
|
return $ Just $ avsIdChanges <> autoNoDiffs
|
|
return (basediffs, autoDiffs)
|
|
|
|
-- (Just BtnSynchLicences) -> do
|
|
-- res <- try synchAvsLicences
|
|
-- case res of
|
|
-- (Right True) ->
|
|
-- return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
|
|
-- (Right False) ->
|
|
-- return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
|
|
-- (Left e) -> do
|
|
-- let msg = tshow (e :: SomeException)
|
|
-- return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
|
|
|
|
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
|
|
siteLayoutMsg MsgMenuAvs $ do
|
|
setTitleI MsgMenuAvs
|
|
let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
|
|
personForm = wrapFormHere pwidget penctype
|
|
statusForm = wrapFormHere swidget senctype
|
|
contactForm = wrapFormHere cwidget cenctype
|
|
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
|
|
getLicForm = wrapFormHere getLicWgt getLicEnctype
|
|
setLicForm = wrapFormHere setLicWgt setLicEnctype
|
|
-- TODO: use i18nWidgetFile instead if this is to become permanent
|
|
$(widgetFile "avs")
|
|
|
|
{-
|
|
|
|
type SynchTableExpr = ( E.SqlExpr (E.Value AvsPersonId)
|
|
`E.LeftOuterJoin` E.SqlExpr (Entity UserAvs)
|
|
`E.LeftOuterJoin` ( E.SqlExpr (Entity Qualification)
|
|
`E.InnerJoin` E.SqlExpr (Entity QualificationUser)
|
|
`E.InnerJoin` E.SqlExpr (Entity User)
|
|
))
|
|
|
|
type SynchDBRow = (E.Value AvsPersonId, E.Value AvsLicence, Entity Qualification, Entity QualificationUser, Entity User)
|
|
-}
|
|
|
|
-- Buttons only needed for AVS Synching
|
|
data ButtonAvsImportUnknown = BtnAvsImportUnknown
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic)
|
|
instance Universe ButtonAvsImportUnknown
|
|
instance Finite ButtonAvsImportUnknown
|
|
nullaryPathPiece ''ButtonAvsImportUnknown camelToPathPiece
|
|
embedRenderMessage ''UniWorX ''ButtonAvsImportUnknown id
|
|
instance Button UniWorX ButtonAvsImportUnknown where
|
|
btnClasses BtnAvsImportUnknown = [BCIsButton, BCPrimary]
|
|
|
|
data ButtonAvsRevokeUnknown = BtnAvsRevokeUnknown
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic)
|
|
instance Universe ButtonAvsRevokeUnknown
|
|
instance Finite ButtonAvsRevokeUnknown
|
|
nullaryPathPiece ''ButtonAvsRevokeUnknown camelToPathPiece
|
|
embedRenderMessage ''UniWorX ''ButtonAvsRevokeUnknown id
|
|
instance Button UniWorX ButtonAvsRevokeUnknown where
|
|
btnClasses BtnAvsRevokeUnknown = [BCIsButton, BCDanger]
|
|
|
|
|
|
data LicenceTableAction = LicenceTableChangeAvs
|
|
| LicenceTableRevokeFDrive
|
|
| LicenceTableGrantFDrive
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''LicenceTableAction $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''LicenceTableAction id
|
|
|
|
data LicenceTableActionData = LicenceTableChangeAvsData
|
|
| LicenceTableRevokeFDriveData
|
|
{ licenceTableChangeFDriveQId :: QualificationId
|
|
, licenceTableChangeFDriveReason :: Text
|
|
, licenceTableChangeFDriveNotify :: Bool
|
|
}
|
|
| LicenceTableGrantFDriveData
|
|
{ licenceTableChangeFDriveQId :: QualificationId
|
|
, licenceTableChangeFDriveReason :: Text
|
|
, licenceTableChangeFDriveEnd :: Day
|
|
, licenceTableChangeFDriveRenew :: Maybe Bool
|
|
}
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
|
|
postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html
|
|
postProblemAvsSynchR = getProblemAvsSynchR
|
|
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{..}, rsChanged), apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
|
|
let mkLicTbl = mkLicenceTable apidStatus rsChanged
|
|
--
|
|
unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros ->
|
|
runDB $ E.select $ do
|
|
(toZero :& usrAvs) <- X.from $
|
|
E.toValues neZeros `E.leftJoin` E.table @UserAvs
|
|
`X.on` (\(toZero :& usrAvs) -> usrAvs E.?. UserAvsPersonId E.==. E.just toZero)
|
|
E.where_ $ E.isNothing (usrAvs E.?. UserAvsPersonId)
|
|
pure toZero
|
|
let unknownLicenceOwners = E.unValue <$> unknownLicenceOwners'
|
|
numUnknownLicenceOwners = length unknownLicenceOwners
|
|
|
|
(btnImportUnknownWgt, btnImportUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsImportUnknown
|
|
ifNothingM 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!
|
|
--procRes (Left (AvsUserAmbiguous api)) = (Sum 0, Set.singleton api, mempty, mempty)
|
|
--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
|
|
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 ))
|
|
addMessageI ms $ MsgAvsImportIDs oks numUnknownLicenceOwners
|
|
redirect ProblemAvsSynchR
|
|
|
|
(btnRevokeUnknownWgt, btnRevokeUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsRevokeUnknown
|
|
let revokeUnknownExecWgt = btnRevokeUnknownWgt
|
|
revokeUnknownSafetyWgt = [whamlet|
|
|
<div .form-group >
|
|
<div .form-group__input>
|
|
<div .buttongroup>
|
|
^{modalBtn}
|
|
|]
|
|
modalBtn = btnModal MsgBtnAvsRevokeUnknown (btnClasses BtnAvsRevokeUnknown) (Right youSureWgt)
|
|
youSureWgt = [whamlet|
|
|
<h1>
|
|
_{MsgAvsRevokeFor (length unknownLicenceOwners)}
|
|
<p>
|
|
^{revokeUnknownExecWgt}
|
|
|]
|
|
|
|
ifNothingM 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
|
|
then addMessageI Error MsgRevokeUnknownLicencesFail
|
|
else addMessageI Info MsgRevokeUnknownLicencesOk
|
|
redirect ProblemAvsSynchR
|
|
|
|
-- licence differences
|
|
((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,)
|
|
<$> mkLicTbl "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll
|
|
<*> mkLicTbl "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld
|
|
<*> mkLicTbl "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld -- downgrade to Vorfeld
|
|
<*> mkLicTbl "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
|
|
|
|
now <- liftIO getCurrentTime
|
|
let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
|
|
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
|
|
redirect ProblemAvsSynchR -- reload to update all tables
|
|
|
|
procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do
|
|
oks <- runDB $ do
|
|
qIds <- selectKeysList [QualificationAvsLicence ==. Just alic] [] -- sanity check
|
|
if licenceTableChangeFDriveQId `notElem` qIds
|
|
then return (-1)
|
|
else do
|
|
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
|
|
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
|
|
|
|
procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do
|
|
(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 now licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew "Admin Resolution"
|
|
(length uids,) <$> get404 licenceTableChangeFDriveQId
|
|
addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
|
|
redirect ProblemAvsSynchR -- must be outside runDB
|
|
|
|
formResult tres2 $ procRes AvsLicenceRollfeld
|
|
formResult tres1down $ procRes AvsLicenceVorfeld
|
|
formResult tres1up $ procRes AvsLicenceVorfeld
|
|
formResult tres0 $ procRes AvsNoLicence
|
|
|
|
AvsLicenceSynchConf{..} <- getsYesod $ view _appAvsLicenceSynchConf
|
|
siteLayoutMsg MsgAvsTitleLicenceSynch $ do
|
|
setTitleI MsgAvsTitleLicenceSynch
|
|
$(i18nWidgetFile "avs-synchronisation")
|
|
|
|
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)
|
|
|
|
queryUser :: LicenceTableExpr -> E.SqlExpr (Entity User)
|
|
queryUser = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 4 1)
|
|
|
|
queryQualUser :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity QualificationUser))
|
|
queryQualUser = $(E.sqlLOJproj 4 2)
|
|
|
|
queryQualification :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity Qualification))
|
|
queryQualification = $(E.sqlLOJproj 4 3)
|
|
|
|
queryQualBlock :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
|
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 = _dbrOutput . _1
|
|
|
|
resultUser :: Lens' LicenceTableData (Entity User)
|
|
resultUser = _dbrOutput . _2
|
|
|
|
resultQualUser :: Traversal' LicenceTableData (Entity QualificationUser)
|
|
resultQualUser = _dbrOutput . _3 . _Just
|
|
|
|
resultQualification :: Traversal' LicenceTableData (Entity Qualification)
|
|
resultQualification = _dbrOutput . _4 . _Just
|
|
|
|
resultQualBlock :: Traversal' LicenceTableData (Entity QualificationUserBlock)
|
|
resultQualBlock = _dbrOutput . _5 . _Just
|
|
|
|
instance HasEntity LicenceTableData User where
|
|
hasEntity = resultUser
|
|
|
|
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 -> Set AvsPersonId -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
|
|
mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do
|
|
(currentRoute, usrHasAvsRerr) <- liftHandler $ (,)
|
|
<$> fmap (fromMaybe $ error "mkLicenceTable called from 404-handler") (liftHandler getCurrentRoute)
|
|
<*> (messageTooltip <$> messageI Error MsgProblemAvsUsrHadR)
|
|
avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [Asc QualificationName]
|
|
now <- liftIO getCurrentTime
|
|
|
|
let nowaday = utctDay now
|
|
avsQids = entityKey <$> avsQualifications
|
|
qualOpts = pure $ qualificationsOptionList avsQualifications
|
|
-- 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:
|
|
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)
|
|
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)
|
|
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) -> avsPersonNoLinkedCellAdmin a
|
|
-- , 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 . runDBRead . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
|
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
|
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
|
|
E.orderBy [E.asc (comp E.^. CompanyName)]
|
|
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
|
let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor
|
|
companies =
|
|
(\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
|
|
|
|
pure $ intercalate (text2widget "; ") companies
|
|
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $
|
|
if aLic /= AvsLicenceVorfeld
|
|
then
|
|
\(preview resultQualification -> q) -> cellMaybe lmsShortCell q
|
|
else
|
|
\row ->
|
|
let q = row ^? resultQualification
|
|
apid = row ^. resultUserAvs . _userAvsPersonId
|
|
warnCell c = if Set.member apid rsChanged
|
|
then c <> spacerCell <> wgtCell usrHasAvsRerr -- expected to be effectively dead code in practice, but we never know
|
|
else c
|
|
in warnCell $ cellMaybe lmsShortCell q
|
|
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
|
|
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d
|
|
-- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d
|
|
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \row ->
|
|
cellMaybe (qualificationValidUntilCell nowaday (row ^? resultQualBlock)) (row ^? resultQualUser)
|
|
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row ->
|
|
cellMaybe (qualificationValidReasonCell' Nothing True nowaday (row ^? resultQualBlock)) (row ^? resultQualUser)
|
|
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
|
|
) $ \(preview $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> cellMaybe (flip ifIconCell IconNoNotification . not) b
|
|
, sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ sortUserNameLink queryUser
|
|
, ("avspersonno" , SortColumn $ queryUserAvs >>> (E.^. UserAvsNoPerson))
|
|
, ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand))
|
|
, sortUserCompany queryUser
|
|
, ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil))
|
|
, ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh))
|
|
, ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld))
|
|
, ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
|
|
, ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal))
|
|
-- , ("validity" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil))
|
|
]
|
|
|
|
dbtFilter = Map.fromList
|
|
[ fltrUserNameEmail queryUser
|
|
, ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now))
|
|
, ( "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)
|
|
]
|
|
|
|
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
|
|
`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)
|
|
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
|
|
E.orderBy [E.desc countRows']
|
|
E.limit 7
|
|
pure (qblock E.^. QualificationUserBlockReason)
|
|
suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
|
|
suggestionsBlock = mkOptionListText <$> runDBRead (getBlockReasons E.not__)
|
|
suggestionsUnblock = mkOptionListText <$> runDBRead (getBlockReasons id)
|
|
|
|
acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
|
|
acts = mconcat
|
|
[ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData
|
|
, if aLic == AvsNoLicence
|
|
then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData
|
|
<$> apreq (selectField qualOpts) (fslI MsgQualificationName) aLicQid
|
|
<*> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
|
|
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
|
|
|
|
else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData
|
|
<$> apreq (selectField qualOpts) (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
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional
|
|
= renderAForm FormStandard
|
|
$ (, mempty) . First . Just
|
|
<$> multiActionA acts (fslI MsgTableAction) (Just LicenceTableChangeAvs)
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
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
|
|
(First (Just act), usrMap) <- inp
|
|
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
|
return (act, usrSet)
|
|
|
|
over _1 postprocess <$> dbTable validator DBTable{..}
|
|
|
|
|
|
|
|
data UserAvsAction = UserAvsSwitchCompany
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''UserAvsAction $ camelToPathPiece' 1
|
|
embedRenderMessage ''UniWorX ''UserAvsAction id
|
|
instance Button UniWorX UserAvsAction where
|
|
btnClasses UserAvsSwitchCompany = [BCIsButton, BCDefault]
|
|
|
|
|
|
getAdminAvsUserR, postAdminAvsUserR :: CryptoUUIDUser -> Handler Html
|
|
getAdminAvsUserR = postAdminAvsUserR
|
|
postAdminAvsUserR uuid = do
|
|
isModal <- hasCustomHeader HeaderIsModal
|
|
|
|
uid <- decrypt uuid
|
|
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
|
|
-- let fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic
|
|
let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID))
|
|
-- fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID))
|
|
mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
|
|
-- mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId
|
|
mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses
|
|
-- $logInfoS "AVS-1" [st|Status query for #{tshow userAvsPersonId} lieferte #{tshow mbStatus} |] -- DEBUG
|
|
let compsUsed :: [CompanyName] = mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just . to stripCI
|
|
compDict <- if 1 >= length compsUsed
|
|
then return mempty -- switch company only sensible if there is more than one company to choose
|
|
else do
|
|
let switchCompFormHandler :: [(CompanyName,CompanyId)] -> Maybe CompanyId -> Handler Widget
|
|
switchCompFormHandler availComps _ | 1 >= length availComps = return mempty -- don't offer a form if there is only one company
|
|
switchCompFormHandler availComps mbPrime = do
|
|
let switchCompForm :: AForm (HandlerFor UniWorX) (CryptoUUIDUser,CompanyId)
|
|
switchCompForm = (,)
|
|
<$> apopt hiddenField "" (Just uuid)
|
|
<*> areq (selectFieldList [(ciOriginal cn, cid) | (cn, cid) <- availComps]) (fslI MsgUserAvsSwitchCompanyField) mbPrime
|
|
<* aopt (buttonField UserAvsSwitchCompany) "" Nothing
|
|
switchCompValidate :: FormValidator (CryptoUUIDUser,CompanyId) Handler ()
|
|
switchCompValidate = do
|
|
(uuid_rcvd,_) <- State.get
|
|
guardValidation MsgWrongButtonValue $ uuid_rcvd == uuid
|
|
((spRes, spWgt), spEnc) <- runFormPost . validateForm switchCompValidate . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchCompForm
|
|
formResultModal spRes (AdminAvsUserR uuid) (\(_,cid) -> do
|
|
lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes)
|
|
problems <- liftHandler . runDB $ do
|
|
(usrUp, problems) <- switchAvsUserCompany True False uid cid
|
|
update uid usrUp
|
|
forM problems $ \p -> reportAdminProblem p >> msgAdminProblem p
|
|
forM_ problems (\p -> do
|
|
-- lift $ $logErrorS "AVS" $ "Switch company problem: " <> tshow p -- no instance Show for SomeMessages
|
|
tell . pure =<< messageI Warning p
|
|
)
|
|
let ok = if null problems then Success else Error
|
|
tell . pure =<< messageI ok (MsgUserAvsCompanySwitched $ unCompanyKey cid)
|
|
)
|
|
return $ wrapForm spWgt
|
|
def { formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = spEnc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]}
|
|
(availComps, primName, primId) <- runDB $ do
|
|
mbPrimeUsrComp :: Maybe UserCompany <- getUserPrimaryCompany uid
|
|
mbPrimeComp :: Maybe Company <- traverseJoin (get . userCompanyCompany) mbPrimeUsrComp
|
|
-- let fltrCmps = (CompanyName <-. compsUsed) : maybeEmpty mbPrimeComp (\Company{companyShorthand=pShort} -> [CompanyShorthand !=. pShort])
|
|
comps :: [Entity Company] <- selectList [CompanyName <-. compsUsed] [Asc CompanyName, Asc CompanyAvsId] -- company name is already unique, but AVS sometimes contains uses whitespace
|
|
return ([(companyName v, k) | (Entity k v) <- comps], companyName <$> mbPrimeComp, CompanyKey . companyShorthand <$> mbPrimeComp)
|
|
-- formDict <- Map.traverseWithKey runSwitchFrom compDict
|
|
swForm <- switchCompFormHandler availComps primId
|
|
return (primName, swForm)
|
|
|
|
msgWarningTooltip <- messageI Warning MsgMessageWarning
|
|
let warnBolt = messageTooltip msgWarningTooltip
|
|
heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
|
|
siteLayout heading $ do
|
|
setTitle $ toHtml $ show userAvsNoPerson
|
|
let contactWgt = case mbContact of
|
|
Left err -> exceptionWgt err
|
|
Right (AvsResponseContact adcs) ->
|
|
if null adcs
|
|
then [whamlet|_{MsgAvsPersonSearchEmpty}|]
|
|
else
|
|
let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
|
|
in mconcat cs
|
|
cardsWgt = case mbStatus of
|
|
Left err -> exceptionWgt err
|
|
Right (AvsResponseStatus asts) ->
|
|
if null asts
|
|
then [whamlet|_{MsgAvsStatusSearchEmpty}|]
|
|
else
|
|
let cs = mkCardsWgt compDict . avsStatusPersonCardStatus <$> toList asts
|
|
in mconcat cs
|
|
[whamlet|
|
|
<p>
|
|
^{contactWgt}
|
|
<p>
|
|
^{cardsWgt}
|
|
<p>
|
|
_{MsgAvsCurrentData}
|
|
|]
|
|
where
|
|
mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
|
|
mkContactWgt warnBolt reqAvsNo AvsDataContact
|
|
{ -- avsContactPersonID = _api
|
|
avsContactPersonInfo = AvsPersonInfo{..}
|
|
, avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName }
|
|
} =
|
|
let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
|
|
[whamlet|
|
|
<section .profile>
|
|
<dl .deflist.profile-dl>
|
|
$if avsNoOk
|
|
<dt .deflist__dt>
|
|
_{MsgAvsPersonNo}
|
|
<dd .deflist__dd>
|
|
#{avsInfoPersonNo}
|
|
^{warnBolt}
|
|
_{MsgAvsPersonNoMismatch}
|
|
<dt .deflist__dt>
|
|
_{MsgAvsLastName}
|
|
<dd .deflist__dd>
|
|
#{avsInfoLastName}
|
|
<dt .deflist__dt>
|
|
_{MsgAvsFirstName}
|
|
<dd .deflist__dd>
|
|
#{avsInfoFirstName}
|
|
<dt .deflist__dt>
|
|
_{MsgAvsPrimaryCompany}
|
|
<dd .deflist__dd>
|
|
#{firmName}
|
|
$maybe bday <- avsInfoDateOfBirth
|
|
<dt .deflist__dt>
|
|
_{MsgAdminUserBirthday}
|
|
<dd .deflist__dd>
|
|
^{formatTimeW SelFormatDate bday}
|
|
<dt .deflist__dt>
|
|
_{MsgAvsLicence}
|
|
<dd .deflist__dd>
|
|
$maybe licence <- parseAvsLicence avsInfoRampLicence
|
|
_{licence}
|
|
$nothing
|
|
_{MsgAvsNoLicenceGuest}
|
|
|]
|
|
|
|
-- mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget, Widget) -> Set AvsDataPersonCard -> Widget
|
|
mkCardsWgt :: (Maybe CompanyName, Widget) -> Set AvsDataPersonCard -> Widget
|
|
mkCardsWgt (mbPrimName, swForm) crds
|
|
| null crds = [whamlet|_{MsgAvsCardsEmpty}|]
|
|
| otherwise = do
|
|
let hasCompany = isJust $ Set.foldr ((<|>) . avsDataFirm) Nothing crds -- some if, since a true AVS status query never delivers values for these fields, but queryAvsFullStatus-workaround does
|
|
hasIssueDate = isJust $ Set.foldr ((<|>) . avsDataIssueDate) Nothing crds
|
|
hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo) Nothing crds
|
|
[whamlet|
|
|
<div .scrolltable .scrolltable-bordered>
|
|
<table .table .table--striped>
|
|
<thead>
|
|
<tr .table__row .table__row--head>
|
|
<th .table__th>_{MsgAvsCardNo}
|
|
<th .table__th>_{MsgTableAvsCardValid}
|
|
<th .table__th>_{MsgAvsCardColor}
|
|
<th .table__th>_{MsgAvsCardAreas}
|
|
$if hasIssueDate
|
|
<th .table__th>_{MsgTableAvsCardIssueDate}
|
|
$if hasValidToDate
|
|
<th .table__th>_{MsgTableAvsCardValidTo}
|
|
$if hasCompany
|
|
<th .table__th>_{MsgTableCompany}
|
|
<th .table__th>_{MsgAvsPrimaryCompany}
|
|
<tbody>
|
|
$forall c <- Set.toDescList crds
|
|
$with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
|
|
<tr .table__row>
|
|
<td .table__td>
|
|
#{tshowAvsFullCardNo (getFullCardNo c)}
|
|
<td .table__td>
|
|
#{boolSymbol avsDataValid}
|
|
<td .table__td>
|
|
_{avsDataCardColor}
|
|
<td .table__td>
|
|
$forall a <- avsDataCardAreas
|
|
#{a} #
|
|
$if hasIssueDate
|
|
<td .table__td>
|
|
$maybe d <- avsDataIssueDate
|
|
^{formatTimeW SelFormatDate d}
|
|
$if hasValidToDate
|
|
<td .table__td>
|
|
$maybe d <- avsDataValidTo
|
|
^{formatTimeW SelFormatDate d}
|
|
$if hasCompany
|
|
<td .table__td>
|
|
$maybe f <- avsDataFirm
|
|
#{f}
|
|
<td .table__td>
|
|
$maybe f <- avsDataFirm
|
|
$with fci <- stripCI f
|
|
$maybe primName <- mbPrimName
|
|
$if (primName == fci)
|
|
_{MsgAvsPrimaryCompany}
|
|
<p>
|
|
^{swForm}
|
|
|]
|
|
|
|
|
|
|
|
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) -- , E.substring (usravs E.^. UserAvsLastSynchError) (E.val ("'#\"%#\" %'") (E.val "#")) -- needs a different type on substring
|
|
querryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs)
|
|
querryUsrAvs = $(E.sqlIJproj 2 1)
|
|
querryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
|
|
querryUser = $(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 = querryUsrAvs >>> (E.^. UserAvsId)
|
|
dbtProj = dbtProjId
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ colUserNameModalHdrAdmin 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 = Map.fromList
|
|
[ sortUserNameLink querryUser
|
|
, ("avs-nr" , SortColumn $ querryUsrAvs >>> (E.^. UserAvsNoPerson))
|
|
, ("avs-last-synch", SortColumnNullsInv $ querryUsrAvs >>> (E.^. UserAvsLastSynch))
|
|
, ("avs-last-error", SortColumn $ querryUsrAvs >>> (E.^. UserAvsLastSynchError))
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ fltrUserNameEmail querryUser
|
|
, ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to querryUsrAvs) (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}|]
|