334 lines
16 KiB
Haskell
334 lines
16 KiB
Haskell
module Handler.Admin where
|
|
|
|
import Import
|
|
import Jobs
|
|
import Handler.Utils
|
|
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
|
|
|
|
import Control.Monad.Trans.Except
|
|
import Control.Monad.Trans.Writer (mapWriterT)
|
|
|
|
import Utils.Lens
|
|
|
|
-- import Data.Time
|
|
import qualified Data.Text as Text
|
|
-- import Data.Function ((&))
|
|
-- import Yesod.Form.Bootstrap3
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
import Database.Persist.Sql (fromSqlKey)
|
|
import qualified Database.Esqueleto as E
|
|
import Database.Esqueleto.Utils as E
|
|
|
|
import Handler.Utils.Table.Cells
|
|
import qualified Handler.Utils.TermCandidates as Candidates
|
|
|
|
-- import Colonnade hiding (fromMaybe)
|
|
-- import Yesod.Colonnade
|
|
|
|
-- import qualified Data.UUID.Cryptographic as UUID
|
|
|
|
|
|
|
|
|
|
getAdminR :: Handler Html
|
|
getAdminR = -- do
|
|
siteLayoutMsg MsgAdminHeading $ do
|
|
setTitleI MsgAdminHeading
|
|
[whamlet|
|
|
This shall become the Administrators' overview page.
|
|
Its current purpose is to provide links to some important admin functions
|
|
|]
|
|
|
|
-- BEGIN - Buttons needed only here
|
|
data ButtonCreate = CreateMath | CreateInf -- Dummy for Example
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonCreate
|
|
instance Finite ButtonCreate
|
|
|
|
nullaryPathPiece ''ButtonCreate camelToPathPiece
|
|
|
|
instance Button UniWorX ButtonCreate where
|
|
btnLabel CreateMath = [whamlet|Ma<i>thema</i>tik|]
|
|
btnLabel CreateInf = "Informatik"
|
|
|
|
btnClasses CreateMath = [BCIsButton, BCInfo]
|
|
btnClasses CreateInf = [BCIsButton, BCPrimary]
|
|
-- END Button needed only here
|
|
|
|
emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext)
|
|
emailTestForm = (,)
|
|
<$> areq emailField (fslI MsgMailTestFormEmail) Nothing
|
|
<*> ( MailContext
|
|
<$> (MailLanguages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing)
|
|
<*> (toMailDateTimeFormat
|
|
<$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing
|
|
<*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing
|
|
<*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing
|
|
)
|
|
)
|
|
<* submitButton
|
|
where
|
|
toMailDateTimeFormat dt d t = \case
|
|
SelFormatDateTime -> dt
|
|
SelFormatDate -> d
|
|
SelFormatTime -> t
|
|
|
|
makeDemoForm :: Int -> Form (Int,Bool,Double)
|
|
makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do
|
|
(result, widget) <- flip (renderAForm FormStandard) html $ (,,)
|
|
<$> areq (minIntField n "Zahl") (fromString $ "Ganzzahl > " ++ show n) Nothing
|
|
<* aformSection MsgFormBehaviour
|
|
<*> areq checkBoxField "Muss nächste Zahl größer sein?" (Just True)
|
|
<*> areq doubleField "Fliesskommazahl" Nothing
|
|
<* submitButton
|
|
return $ case result of
|
|
FormSuccess fsres
|
|
| errorMsgs <- validateResult fsres
|
|
, not $ null errorMsgs -> (FormFailure errorMsgs, widget)
|
|
_otherwise -> (result, widget)
|
|
where
|
|
validateResult :: (Int,Bool,Double) -> [Text]
|
|
validateResult (i,True,d) | fromIntegral i >= d = [tshow d <> " ist nicht größer als " <> tshow i, "Zweite Fehlermeldung", "Dritte Fehlermeldung"]
|
|
validateResult _other = []
|
|
|
|
|
|
getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
|
|
getAdminTestR = postAdminTestR
|
|
postAdminTestR = do
|
|
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate)
|
|
case btnResult of
|
|
(FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt"
|
|
(FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
|
|
FormMissing -> return ()
|
|
_other -> addMessage Warning "KEIN Knopf erkannt"
|
|
|
|
((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm
|
|
formResultModal emailResult AdminTestR $ \(email, ls) -> do
|
|
jId <- mapWriterT runDB $ do
|
|
jId <- queueJob $ JobSendTestEmail email ls
|
|
tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|]
|
|
return jId
|
|
writeJobCtl $ JobCtlPerform jId
|
|
|
|
let emailWidget' = [whamlet|
|
|
<form method=post action=@{AdminTestR} enctype=#{emailEnctype} data-ajax-submit>
|
|
^{emailWidget}
|
|
|]
|
|
|
|
|
|
let demoFormAction (_i,_b,_d) = addMessage Info "All ok."
|
|
((demoResult, formWidget),formEnctype) <- runFormPost $ makeDemoForm 7
|
|
formResult demoResult demoFormAction
|
|
let actionUrl = AdminTestR
|
|
let showDemoResult = [whamlet|
|
|
$maybe (i,b,d) <- formResult' demoResult
|
|
Received values:
|
|
<ul>
|
|
<li>#{show i}
|
|
<li>#{show b}
|
|
<li>#{show d}
|
|
$nothing
|
|
No form values received, due to #
|
|
$# Using formResult' above means that we usually to not distinguish the following two cases here, sind formResult does this already:
|
|
$case demoResult
|
|
$of FormSuccess _
|
|
$# Already dealt with above, to showecase usage of formResult' as normally done.
|
|
success, which should not happen here.
|
|
$of FormMissing
|
|
Form data missing, probably empty.
|
|
$of FormFailure msgs
|
|
<ul>
|
|
$forall m <- msgs
|
|
<li>#{m}
|
|
|]
|
|
|
|
let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
|
|
siteLayout locallyDefinedPageHeading $ do
|
|
-- defaultLayout $ do
|
|
setTitle "Uni2work Admin Testpage"
|
|
$(widgetFile "adminTest")
|
|
|
|
[whamlet|<h2>Formular Demonstration|]
|
|
$(widgetFile "formPage")
|
|
showDemoResult
|
|
|
|
|
|
getAdminErrMsgR, postAdminErrMsgR :: Handler Html
|
|
getAdminErrMsgR = postAdminErrMsgR
|
|
postAdminErrMsgR = do
|
|
((ctResult, ctView), ctEncoding) <- runFormPost . renderAForm FormStandard $
|
|
(unTextarea <$> areq textareaField (fslpI MsgErrMsgCiphertext "Ciphertext") Nothing)
|
|
<* submitButton
|
|
|
|
plaintext <- formResultMaybe ctResult $ exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) . (encodedSecretBoxOpen :: Text -> ExceptT EncodedSecretBoxException Handler Value)
|
|
|
|
defaultLayout
|
|
[whamlet|
|
|
$maybe t <- plaintext
|
|
<pre style="white-space:pre-wrap; font-family:monospace">
|
|
#{encodePrettyToTextBuilder t}
|
|
|
|
<form action=@{AdminErrMsgR} method=post enctype=#{ctEncoding}>
|
|
^{ctView}
|
|
|]
|
|
|
|
|
|
-- BEGIN - Buttons needed only for StudyTermCandidateManagement
|
|
data ButtonInferStudyTerms = ButtonInferStudyTerms
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonInferStudyTerms
|
|
instance Finite ButtonInferStudyTerms
|
|
|
|
nullaryPathPiece ''ButtonInferStudyTerms camelToPathPiece
|
|
|
|
instance Button UniWorX ButtonInferStudyTerms where
|
|
btnLabel ButtonInferStudyTerms = "Studienfachzuordnung automatisch lernen"
|
|
btnClasses ButtonInferStudyTerms = [BCIsButton, BCPrimary]
|
|
-- END Button needed only here
|
|
|
|
getAdminFeaturesR, postAdminFeaturesR :: Handler Html
|
|
getAdminFeaturesR = postAdminFeaturesR
|
|
postAdminFeaturesR = do
|
|
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonInferStudyTerms)
|
|
(infConflicts,infAccepted) <- case btnResult of
|
|
(FormSuccess ButtonInferStudyTerms) -> do
|
|
(infConflicts,infAmbiguous,infRedundant,infAccepted) <- Candidates.inferHandler
|
|
unless (null infAmbiguous) $ addMessageI Info $ MsgAmbiguousCandidatesRemoved $ length infAmbiguous
|
|
unless (null infRedundant) $ addMessageI Info $ MsgRedundantCandidatesRemoved $ length infRedundant
|
|
if null infAccepted
|
|
then addMessageI Info MsgNoCandidatesInferred
|
|
else addMessageI Success $ MsgCandidatesInferred $ length infAccepted
|
|
return (infConflicts,infAccepted)
|
|
_other -> (,[]) <$> runDB Candidates.conflicts
|
|
unless (null infConflicts) $ addMessage Warning "KONFLIKTE vorhanden" --TODO i18n
|
|
|
|
( (degreeResult,degreeTable)
|
|
, (studyTermsResult,studytermsTable)
|
|
, ((),candidateTable)) <- runDB $ (,,)
|
|
<$> mkDegreeTable
|
|
<*> mkStudytermsTable (Set.fromList $ map (StudyTermsKey' . fst) infAccepted)
|
|
<*> mkCandidateTable
|
|
|
|
let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
|
|
degreeResult' = degreeResult <&> getDBFormResult
|
|
(\row -> ( row ^. _dbrOutput . _entityVal . _studyDegreeName
|
|
, row ^. _dbrOutput . _entityVal . _studyDegreeShorthand
|
|
))
|
|
updateDegree degreeKey (name,short) = update degreeKey [StudyDegreeName =. name, StudyDegreeShorthand =. short]
|
|
formResult degreeResult' $ \res -> do
|
|
void . runDB $ Map.traverseWithKey updateDegree res
|
|
addMessageI Success MsgStudyDegreeChangeSuccess
|
|
|
|
let studyTermsResult' :: FormResult (Map (Key StudyTerms) (Maybe Text, Maybe Text))
|
|
studyTermsResult' = studyTermsResult <&> getDBFormResult
|
|
(\row -> ( row ^. _dbrOutput . _entityVal . _studyTermsName
|
|
, row ^. _dbrOutput . _entityVal . _studyTermsShorthand
|
|
))
|
|
updateStudyTerms studyTermsKey (name,short) = update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short]
|
|
formResult studyTermsResult' $ \res -> do
|
|
void . runDB $ Map.traverseWithKey updateStudyTerms res
|
|
addMessageI Success MsgStudyTermsChangeSuccess
|
|
|
|
siteLayoutMsg MsgAdminFeaturesHeading $ do
|
|
setTitleI MsgAdminFeaturesHeading
|
|
$(widgetFile "adminFeatures")
|
|
where
|
|
textInputCell lensRes lensDefault = formCell id (return . view (_dbrOutput . _entityKey))
|
|
(\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
|
|
<$> mopt textField "" (Just $ row ^. lensDefault)
|
|
)
|
|
|
|
|
|
mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget)
|
|
mkDegreeTable =
|
|
let dbtIdent = "admin-studydegrees" :: Text
|
|
dbtStyle = def
|
|
dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery ( E.SqlExpr (Entity StudyDegree))
|
|
dbtSQLQuery = return
|
|
dbtRowKey = (E.^. StudyDegreeKey)
|
|
dbtProj = return
|
|
dbtColonnade = formColonnade $ mconcat
|
|
[ sortable (Just "key") (i18nCell MsgDegreeKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
|
|
, sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName))
|
|
, sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand))
|
|
, dbRow
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ ("key" , SortColumn (E.^. StudyDegreeKey))
|
|
, ("name" , SortColumn (E.^. StudyDegreeName))
|
|
, ("short", SortColumn (E.^. StudyDegreeShorthand))
|
|
]
|
|
dbtFilter = mempty
|
|
dbtFilterUI = mempty
|
|
dbtParams = def { dbParamsFormAddSubmit = True
|
|
, dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
|
|
}
|
|
psValidator = def & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
|
|
in dbTable psValidator DBTable{..}
|
|
|
|
mkStudytermsTable :: Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
|
|
mkStudytermsTable newKeys =
|
|
let dbtIdent = "admin-studyterms" :: Text
|
|
dbtStyle = def
|
|
dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery ( E.SqlExpr (Entity StudyTerms))
|
|
dbtSQLQuery = return
|
|
dbtRowKey = (E.^. StudyTermsKey)
|
|
dbtProj = return
|
|
dbtColonnade = formColonnade $ mconcat
|
|
[ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermsKey))
|
|
, sortable (Just "isnew") (i18nCell MsgStudyTermIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey))
|
|
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName))
|
|
, sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand))
|
|
, dbRow
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ ("key" , SortColumn (E.^. StudyTermsKey))
|
|
, ("isnew" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsId `E.in_` E.valList (Set.toList newKeys)))
|
|
, ("name" , SortColumn (E.^. StudyTermsName))
|
|
, ("short" , SortColumn (E.^. StudyTermsShorthand))
|
|
]
|
|
dbtFilter = mempty
|
|
dbtFilterUI = mempty
|
|
dbtParams = def { dbParamsFormAddSubmit = True
|
|
, dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
|
|
}
|
|
psValidator = def & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
|
|
in dbTable psValidator DBTable{..}
|
|
|
|
mkCandidateTable =
|
|
let dbtIdent = "admin-termcandidate" :: Text
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtSQLQuery :: E.SqlExpr (Entity StudyTermCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermCandidate))
|
|
dbtSQLQuery = return
|
|
dbtRowKey = (E.^. StudyTermCandidateId)
|
|
dbtProj = return
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ dbRow
|
|
, sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermCandidateKey))
|
|
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermCandidateName))
|
|
, sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermCandidateIncidence))
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ ("key" , SortColumn (E.^. StudyTermCandidateKey))
|
|
, ("name" , SortColumn (E.^. StudyTermCandidateName))
|
|
, ("incidence", SortColumn (E.^. StudyTermCandidateIncidence))
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ ("key", FilterColumn $ mkExactFilter (E.^. StudyTermCandidateKey))
|
|
, ("name", FilterColumn $ mkContainsFilter (E.^. StudyTermCandidateName))
|
|
, ("incidence", FilterColumn $ mkExactFilter (E.^. StudyTermCandidateIncidence)) -- contains filter desired, but impossible here
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
-- [ prismAForm (singletonFilter "key") mPrev $ aopt intField (fslI MsgStudyTermsKey) -- Typing problem exactFilter suffices here
|
|
[ prismAForm (singletonFilter "key") mPrev $ aopt (searchField False) (fslI MsgStudyTermsKey)
|
|
, prismAForm (singletonFilter "name") mPrev $ aopt (searchField False) (fslI MsgStudyTermsName)
|
|
, prismAForm (singletonFilter "incidence") mPrev $ aopt (searchField False) (fslI MsgStudyCandidateIncidence)
|
|
]
|
|
dbtParams = def
|
|
psValidator = def & defaultSorting [SortAscBy "incidence", SortAscBy "key", SortAscBy "name"]
|
|
in dbTable psValidator DBTable{..}
|
|
|