610 lines
33 KiB
Haskell
610 lines
33 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.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
|
|
, getProblemAvsSynchR, postProblemAvsSynchR
|
|
) where
|
|
|
|
import Import
|
|
import qualified Control.Monad.State.Class as State
|
|
-- import Data.Aeson (encode)
|
|
import qualified Data.Text as Text
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
-- import Database.Persist.Sql (updateWhereCount)
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Avs
|
|
-- import Handler.Utils.Qualification
|
|
|
|
import Utils.Avs
|
|
|
|
|
|
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
|
|
|
|
---------------------------
|
|
-- PAGINATION WORKAROUND --
|
|
|
|
|
|
data PaginationParameters = PaginationParameters { pagLimit, pagOffset:: Int64 }
|
|
deriving (Eq, Show)
|
|
|
|
instance Default PaginationParameters where
|
|
def = PaginationParameters { pagLimit = 100, pagOffset = 0}
|
|
|
|
makePaginationForm :: Maybe PaginationParameters -> Form PaginationParameters
|
|
makePaginationForm tmpl = identifyForm FIDPaginationWorkaround . validateForm validatePaginationForm $ \html ->
|
|
flip (renderAForm FormStandard) html $ PaginationParameters
|
|
<$> areq intField (fslI MsgPaginationSize) (pagLimit <$> tmpl)
|
|
<*> areq intField (fslI MsgPaginationPage) (pagOffset <$> tmpl)
|
|
|
|
validatePaginationForm :: FormValidator PaginationParameters Handler ()
|
|
validatePaginationForm = do
|
|
PaginationParameters{..} <- State.get
|
|
guardValidation MsgPaginationError $ pagLimit >= 0 && pagOffset >= 0
|
|
|
|
|
|
-- END PAGINATION WORKAROUND --
|
|
-------------------------------
|
|
|
|
-- avoids repetition of local definitions
|
|
single :: (k,a) -> Map k a
|
|
single = uncurry Map.singleton
|
|
|
|
|
|
-- 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 = "Check all licences" -- 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 AvsQueryStatus -> 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 = catMaybes $ readMay <$> nonemptys
|
|
unparseAvsIds :: AvsQueryStatus -> Text
|
|
unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
|
|
|
|
validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler ()
|
|
validateAvsQueryStatus = do
|
|
AvsQueryStatus 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
|
|
AVS Konfiguration ist #{decodeUtf8 (avsUser avsConf)}@#{avsHost avsConf}:#{avsPort avsConf}
|
|
$nothing
|
|
AVS nicht konfiguriert!
|
|
|]
|
|
mAvsQuery <- getsYesod $ view _appAvsQuery
|
|
case mAvsQuery of
|
|
Nothing -> return mempty
|
|
Just AvsQuery{..} -> do
|
|
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
|
|
|
|
let procFormPerson fr = do
|
|
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
|
|
res <- avsQueryPerson fr
|
|
case res of
|
|
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
|
Right (AvsResponsePerson pns) -> return $ Just [whamlet|
|
|
<ul>
|
|
$forall p <- pns
|
|
<li>#{tshow p}
|
|
|]
|
|
mbPerson <- formResultMaybe presult procFormPerson
|
|
|
|
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
|
|
let procFormStatus fr = do
|
|
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
|
|
res <- avsQueryStatus fr
|
|
case res of
|
|
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
|
Right (AvsResponseStatus pns) -> return $ Just [whamlet|
|
|
<ul>
|
|
$forall p <- pns
|
|
<li>#{tshow p}
|
|
|]
|
|
mbStatus <- formResultMaybe sresult procFormStatus
|
|
|
|
((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) -> do
|
|
let msg = tshow (e :: SomeException)
|
|
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
|
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 = do
|
|
res <- avsQueryGetAllLicences
|
|
case res of
|
|
(Right (AvsResponseGetLicences lics)) -> do
|
|
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 $ Just [whamlet|
|
|
<h2>Success:</h2>
|
|
<ul>
|
|
$forall AvsPersonLicence{..} <- flics
|
|
<li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
|
|
|]
|
|
|
|
(Left err) -> do
|
|
let msg = tshow err
|
|
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
|
mbGetLic <- formResultMaybe getLicRes 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 <- case qryLicRes of
|
|
Nothing -> return Nothing
|
|
(Just BtnCheckLicences) -> do
|
|
res <- try $ do
|
|
allLicences <- throwLeftM avsQueryGetAllLicences
|
|
computeDifferingLicences allLicences
|
|
case res of
|
|
(Right diffs) -> do
|
|
let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
|
|
r_grant = showLics AvsLicenceRollfeld
|
|
f_set = showLics AvsLicenceVorfeld
|
|
revoke = showLics AvsNoLicence
|
|
return $ Just [whamlet|
|
|
<h2>Licence check differences:
|
|
<h3>Grant R:
|
|
<p>
|
|
#{r_grant}
|
|
<h3>Set to F:
|
|
<p>
|
|
#{f_set}
|
|
<h3>Revoke licence:
|
|
<p>
|
|
#{revoke}
|
|
|]
|
|
(Left e) -> do
|
|
let msg = tshow (e :: SomeException)
|
|
return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
|
|
-- (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
|
|
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 --TODO: add { licenceTableChangeFDriveQId :: QualificationId to avoid lookup later
|
|
| LicenceTableGrantFDriveData { licenceTableChangeFDriveQId :: QualificationId
|
|
, 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
|
|
AvsLicenceDifferences{..} <- catchAllAvs' AdminR retrieveDifferingLicences
|
|
|
|
--
|
|
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
|
|
ifMaybeM btnImportUnknownRes () $ \BtnAvsImportUnknown -> catchAllAvs $ do
|
|
res <- 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}
|
|
|]
|
|
|
|
ifMaybeM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> catchAllAvs $ do
|
|
let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners
|
|
no_revokes = Set.size revokes
|
|
oks <- setLicencesAvs revokes
|
|
if oks < no_revokes
|
|
then addMessageI Error MsgRevokeUnknownLicencesFail
|
|
else addMessageI Info MsgRevokeUnknownLicencesOk
|
|
redirect ProblemAvsSynchR
|
|
|
|
currentRoute <- fromMaybe (error "getProblemsAvsSynchR called from 404-handler") <$> liftHandler getCurrentRoute
|
|
((fromMaybe def . formResultToMaybe -> pagResult, pagWidget), pagEnctype) <- runFormGet $ makePaginationForm def
|
|
let pagForm = wrapForm pagWidget def { formMethod = GET, formEncoding = pagEnctype, formAction = Just $ SomeRoute currentRoute }
|
|
|
|
-- licence differences
|
|
((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,)
|
|
<$> mkLicenceTable pagResult "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll
|
|
<*> mkLicenceTable pagResult "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld
|
|
<*> mkLicenceTable pagResult "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld
|
|
<*> mkLicenceTable pagResult "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
|
|
|
|
now <- liftIO getCurrentTime
|
|
let nowaday = utctDay now
|
|
procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
|
|
procRes aLic (LicenceTableChangeAvsData , apids) = catchAllAvs $ do
|
|
oks <- setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
|
|
let no_req = Set.size apids
|
|
mkind = if oks < no_req then Warning else Success
|
|
addMessageI mkind $ MsgAvsSetLicences aLic oks no_req
|
|
redirect ProblemAvsSynchR -- reload to update all tables
|
|
|
|
procRes alic (LicenceTableRevokeFDriveData, apids) = do
|
|
nups <- runDB $ do
|
|
qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic
|
|
selectedUsers <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
|
|
forM_ selectedUsers $ upsertQualificationUser qId nowaday (pred nowaday) Nothing
|
|
return $ length selectedUsers
|
|
addMessageI Success $ MsgRevokeFraDriveLicences alic nups
|
|
redirect ProblemAvsSynchR -- must be outside runDB
|
|
|
|
procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do
|
|
(n, Qualification{qualificationShorthand}) <- runDB $ do
|
|
uas <- selectList [UserAvsPersonId <-. Set.toList apids] []
|
|
let uids = view _userAvsUser <$> uas
|
|
-- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
|
|
forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
|
|
(length uids,) <$> get404 licenceTableChangeFDriveQId
|
|
addMessageI Success $ 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
|
|
|
|
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))
|
|
)
|
|
|
|
queryUserAvs :: LicenceTableExpr -> E.SqlExpr (Entity UserAvs)
|
|
queryUserAvs = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 3 1)
|
|
|
|
queryUser :: LicenceTableExpr -> E.SqlExpr (Entity User)
|
|
queryUser = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 3 1)
|
|
|
|
queryQualUser :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity QualificationUser))
|
|
queryQualUser = $(E.sqlLOJproj 3 2)
|
|
|
|
queryQualification :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity Qualification))
|
|
queryQualification = $(E.sqlLOJproj 3 3)
|
|
|
|
type LicenceTableData = DBRow (Entity UserAvs, Entity User, Maybe (Entity QualificationUser), Maybe (Entity Qualification))
|
|
|
|
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
|
|
|
|
instance HasEntity LicenceTableData User where
|
|
hasEntity = resultUser
|
|
|
|
instance HasUser LicenceTableData where
|
|
hasUser = resultUser . _entityVal
|
|
|
|
|
|
mkLicenceTable :: PaginationParameters -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
|
|
mkLicenceTable PaginationParameters{..} dbtIdent aLic apids = do
|
|
currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
|
|
avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] []
|
|
now <- liftIO getCurrentTime
|
|
let nowaday = utctDay now
|
|
-- 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) -> do
|
|
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)
|
|
when (pagLimit > 0) $ E.limit pagLimit >> E.offset (pagLimit * pagOffset) -- TODO: why does pagination not work here?
|
|
return (usrAvs, user, qualUser, qual)
|
|
dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR?
|
|
-- Not sure what changes here:
|
|
dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali)
|
|
-- dbtProj = dbtProjFilteredPostId
|
|
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) -> avsPersonNoCell a
|
|
-- , colUserCompany
|
|
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
|
|
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
|
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
|
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
|
|
E.orderBy [E.asc (comp E.^. CompanyName)]
|
|
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
|
let companies = intersperse (text2markup ", ") $
|
|
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
|
|
icnSuper = text2markup " " <> icon IconSupervisor
|
|
pure $ toWgt $ mconcat companies
|
|
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q
|
|
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d
|
|
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d
|
|
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
|
|
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
|
|
) $ \(preview $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> cellMaybe qualificationBlockedCell b
|
|
]
|
|
dbtSorting = mconcat
|
|
[ single $ sortUserNameLink queryUser
|
|
, single ("avspersonno" , SortColumn $ queryUserAvs >>> (E.^. UserAvsNoPerson))
|
|
, single ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand))
|
|
, single $ sortUserCompany queryUser
|
|
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil))
|
|
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh))
|
|
, single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld))
|
|
, single ("blocked-due" , SortColumn $ queryQualUser >>> (E.?. QualificationUserBlockedDue))
|
|
]
|
|
|
|
dbtFilter = mconcat
|
|
[ single $ fltrUserNameEmail queryUser
|
|
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' nowaday)) -- why does this not work?
|
|
, single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
|
|
E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
|
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
|
|
(E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
|
|
testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
|
|
testcrit = maybe testname testnumber $ readMay $ CI.original criterion
|
|
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
|
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
|
|
)
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
|
|
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
|
|
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
|
|
]
|
|
|
|
qualOpt :: Entity Qualification -> Handler (Option QualificationId)
|
|
qualOpt (Entity qualId qual) = do
|
|
cQualId :: CryptoUUIDQualification <- encrypt qualId
|
|
return $ Option
|
|
{ optionDisplay = CI.original $ qualificationName qual
|
|
, optionInternalValue = qualId
|
|
, optionExternalValue = tshow cQualId
|
|
}
|
|
aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications
|
|
acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
|
|
acts = mconcat
|
|
[ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData
|
|
, if aLic == AvsNoLicence
|
|
then singletonMap LicenceTableRevokeFDrive $ pure LicenceTableRevokeFDriveData
|
|
else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData
|
|
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
|
|
<*> 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 [SortDescBy "column-label"]
|
|
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{..} |