492 lines
25 KiB
Haskell
492 lines
25 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.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Avs
|
|
|
|
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
|
|
|
|
-- avoids repetition of local definitions
|
|
single :: (k,a) -> Map k a
|
|
single = uncurry Map.singleton
|
|
|
|
|
|
-- Button needed only here
|
|
data ButtonAvsTest = BtnCheckLicences | BtnSynchLicences
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
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
|
|
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 $ upsertAvsUser 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)
|
|
-}
|
|
|
|
|
|
data ButtonAvsSynch = BtnImportUnknownAvsIds | BtnRevokeAvsLicences
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonAvsSynch
|
|
instance Finite ButtonAvsSynch
|
|
|
|
nullaryPathPiece ''ButtonAvsSynch camelToPathPiece
|
|
embedRenderMessage ''UniWorX ''ButtonAvsSynch id
|
|
|
|
instance Button UniWorX ButtonAvsSynch where
|
|
btnClasses BtnImportUnknownAvsIds = [BCIsButton, BCPrimary]
|
|
btnClasses BtnRevokeAvsLicences = [BCIsButton, BCDanger]
|
|
|
|
|
|
data LicenceTableAction = LicenceTableChangeAvs
|
|
| LicenceTableRevokeFDrive
|
|
| LicenceTableGrantFDrive
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
instance Universe LicenceTableAction
|
|
instance Finite LicenceTableAction
|
|
nullaryPathPiece ''LicenceTableAction $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''LicenceTableAction id
|
|
|
|
data LicenceTableActionData = LicenceTableChangeAvsData
|
|
| LicenceTableRevokeFDriveData
|
|
| LicenceTableGrantFDriveData { licenceTableChangeFDriveEnd :: Day }
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
|
|
postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html
|
|
postProblemAvsSynchR = getProblemAvsSynchR
|
|
getProblemAvsSynchR = do
|
|
|
|
-- TODO: just for Testing
|
|
-- now <- liftIO getCurrentTime
|
|
-- let TimeOfDay hours minutes _seconds = timeToTimeOfDay (utctDayTime now)
|
|
-- setTo0 = Set.fromList [AvsPersonId hours, AvsPersonId minutes, AvsPersonId 12345678]
|
|
-- setTo1 = Set.fromList [AvsPersonId minutes]
|
|
-- setTo2 = Set.fromList [AvsPersonId hours, AvsPersonId 12345678]
|
|
-- addMessageI Success $ MsgAvsSetLicences AvsLicenceVorfeld 99 1000
|
|
|
|
(setTo0, setTo1, setTo2) <- try retrieveDifferingLicences >>= \case
|
|
Right res -> return res
|
|
Left err -> do addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
|
|
redirect AdminR
|
|
|
|
unknownLicenceOwners' <- whenNonEmpty setTo0 $ \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
|
|
(btnUnknownWgt, btnUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDAbsUnknownLicences
|
|
case btnUnknownRes of
|
|
Nothing -> return ()
|
|
(Just BtnImportUnknownAvsIds) -> do
|
|
let procAid = fmap (Sum . maybe 0 (const 1)) <$> upsertAvsUserById
|
|
res <- try (getSum <$> foldMapM procAid unknownLicenceOwners)
|
|
case res of
|
|
Right oks -> do
|
|
let ms = if oks == numUnknownLicenceOwners then Info else Warning
|
|
addMessageI ms $ MsgAvsImportIDs oks numUnknownLicenceOwners
|
|
redirect ProblemAvsSynchR
|
|
Left err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
|
|
(Just BtnRevokeAvsLicences) -> do
|
|
let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners
|
|
no_revokes = Set.size revokes
|
|
try (setLicencesAvs revokes) >>= \case
|
|
Right no_ok | no_ok < no_revokes -> addMessageI Error MsgRevokeUnknownLicencesFail
|
|
| otherwise -> addMessageI Info MsgRevokeUnknownLicencesOk
|
|
Left err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
|
|
>> redirect ProblemAvsSynchR
|
|
|
|
((tres0,tb0),(tres1,tb1),(tres2,tb2)) <- runDB $ (,,)
|
|
<$> mkLicenceTable "driveSynchNoLicence" AvsNoLicence setTo0 (Just LicenceTableChangeAvs)
|
|
<*> mkLicenceTable "driveSynchVorfeld" AvsLicenceVorfeld setTo1 (Just LicenceTableChangeAvs)
|
|
<*> mkLicenceTable "driveSynchRollfeld" AvsLicenceRollfeld setTo2 (Just LicenceTableChangeAvs)
|
|
let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
|
|
procRes aLic (LicenceTableChangeAvsData , apids) = do
|
|
try (setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids) >>= \case
|
|
(Right no_ok) -> let no_req = Set.size apids
|
|
mkind = if no_ok < no_req then Warning else Success
|
|
in addMessageI mkind $ MsgAvsSetLicences aLic no_ok no_req
|
|
(Left err) -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
|
|
redirect ProblemAvsSynchR -- reload to update all tables
|
|
procRes _alic r@(_, _apids) = addMessage Info $ toHtml $ tshow r
|
|
formResult tres2 $ procRes AvsLicenceRollfeld
|
|
formResult tres1 $ 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.InnerJoin` E.SqlExpr (Maybe (Entity Qualification))
|
|
)
|
|
|
|
queryUserAvs :: LicenceTableExpr -> E.SqlExpr (Entity UserAvs)
|
|
queryUserAvs = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 2 1)
|
|
|
|
queryUser :: LicenceTableExpr -> E.SqlExpr (Entity User)
|
|
queryUser = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 1)
|
|
|
|
queryQualUser :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity QualificationUser))
|
|
queryQualUser = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 2 2)
|
|
|
|
queryQualification :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity Qualification))
|
|
queryQualification = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 2)
|
|
|
|
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 :: Text -> AvsLicence -> Set AvsPersonId -> Maybe LicenceTableAction -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
|
|
mkLicenceTable dbtIdent aLic apids defAct = do
|
|
currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
|
|
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.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence) -- if we suggest granting that licence, this join should deliver a value too
|
|
-- 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.InnerJoin` 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)
|
|
return (usrAvs, user, qualUser, qual)
|
|
dbtRowKey = (queryUserAvs >>> (E.^. UserAvsPersonId))
|
|
&&& (queryQualification >>> (E.?. QualificationId))
|
|
--dbtProj = dbtProjSimple $ \(user, qualUsr, E.Value api, quali) -> return (user, qualUsr, api, quali) -- just remove Value wrapper in 3rd element
|
|
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
|
|
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe qualificationShortCell 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 ("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?
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
|
|
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
|
|
]
|
|
acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
|
|
acts = mconcat
|
|
[ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData
|
|
, if aLic == AvsNoLicence
|
|
then singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing
|
|
else singletonMap LicenceTableRevokeFDrive $ pure LicenceTableRevokeFDriveData
|
|
]
|
|
dbtParams = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Just $ SomeRoute currentRoute
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional
|
|
= renderAForm FormStandard
|
|
$ (, mempty) . First . Just
|
|
<$> multiActionA acts (fslI MsgTableAction) defAct
|
|
, 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{..} |