207 lines
10 KiB
Haskell
207 lines
10 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
|
|
|
|
module Handler.Admin.Avs
|
|
( getAdminAvsR
|
|
, postAdminAvsR
|
|
) 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 Handler.Utils
|
|
import Handler.Utils.Avs
|
|
|
|
import Utils.Avs
|
|
|
|
-- Button needed only here
|
|
data ButtonAvsTest = BtnCheckLicences
|
|
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
|
|
btnClasses BtnCheckLicences = [BCIsButton, BCPrimary]
|
|
-- 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 (canonical . AvsInternalPersonalNo) 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 -> return . Just $ tshow err
|
|
Right jsn -> return . Just $ tshow jsn
|
|
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 -> return . Just $ tshow err
|
|
Right jsn -> return . Just $ tshow jsn
|
|
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
|
|
let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = AvsPersonId aid }
|
|
addMessage Info $ text2Html $ "See log for detailed errors. Query: " <> tshow (toJSON $ AvsQuerySetLicences req)
|
|
res <- try $ setLicencesAvs req
|
|
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
|
|
|
|
|
|
((qryLicRes, qryLicWgt), qryLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicenceDiffs (buttonForm :: Form ButtonAvsTest)
|
|
let procFormQryLic BtnCheckLicences = do
|
|
res <- try checkLicences
|
|
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>Error:</h2> #{msg}|]
|
|
mbQryLic <- formResultMaybe qryLicRes procFormQryLic
|
|
|
|
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
|
|
qryLicForm = wrapForm qryLicWgt def { formAction = Just $ SomeRoute actionUrl, formEncoding = qryLicEnctype, formSubmit = FormNoSubmit }
|
|
-- TODO: use i18nWidgetFile instead if this is to become permanent
|
|
$(widgetFile "avs")
|