1048 lines
58 KiB
Haskell
1048 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 $ (,)
|
|
<$> (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
|
|
let compsUsed :: [CompanyName] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just
|
|
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}|]
|