241 lines
12 KiB
Haskell
241 lines
12 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.School where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Text as Text
|
|
|
|
|
|
getSchoolListR :: Handler Html
|
|
getSchoolListR = do
|
|
let
|
|
schoolLink :: SchoolId -> SomeRoute UniWorX
|
|
schoolLink ssh = SomeRoute $ SchoolR ssh SchoolEditR
|
|
|
|
dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _
|
|
dbtSQLQuery = return
|
|
|
|
dbtProj = dbtProjId
|
|
|
|
dbtRowKey = (E.^. SchoolId)
|
|
|
|
dbtColonnade :: Colonnade Sortable _ _
|
|
dbtColonnade = mconcat
|
|
[ colSchoolShort $ _dbrOutput . _entityKey
|
|
, anchorColonnade (views (_dbrOutput . _entityKey) schoolLink) $ colSchoolName (_dbrOutput . _entityVal . _schoolName)
|
|
]
|
|
|
|
dbtSorting = mconcat
|
|
[ sortSchoolShort $ to (E.^. SchoolId)
|
|
, sortSchoolName $ to (E.^. SchoolName)
|
|
]
|
|
|
|
dbtFilter = mempty
|
|
dbtFilterUI = mempty
|
|
|
|
dbtStyle = def
|
|
dbtParams = def
|
|
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
|
|
dbtExtraReps = []
|
|
|
|
dbtIdent :: Text
|
|
dbtIdent = "schools"
|
|
|
|
psValidator = def
|
|
& defaultSorting [SortAscBy "school-name"]
|
|
|
|
|
|
table <- runDB $ dbTableWidget' psValidator DBTable{..}
|
|
|
|
let title = MsgHeadingSchoolList
|
|
siteLayoutMsg title $ do
|
|
setTitleI title
|
|
table
|
|
|
|
data SchoolForm = SchoolForm
|
|
{ sfShorthand :: CI Text
|
|
, sfName :: CI Text
|
|
, sfOrgUnits :: Set (CI Text)
|
|
, sfExamMinimumRegisterBeforeStart
|
|
, sfExamMinimumRegisterDuration :: Maybe NominalDiffTime
|
|
, sfExamRequireModeForRegistration :: Bool
|
|
, sfExamDiscouragedModes :: ExamModeDNF
|
|
, sfExamCloseMode :: ExamCloseMode
|
|
, sfSheetAuthorshipStatementMode :: SchoolAuthorshipStatementMode
|
|
, sfSheetAuthorshipStatementDefinition :: Maybe I18nStoredMarkup
|
|
, sfSheetAuthorshipStatementAllowOther :: Bool
|
|
, sfSheetExamAuthorshipStatementMode :: SchoolAuthorshipStatementMode
|
|
, sfSheetExamAuthorshipStatementDefinition :: Maybe I18nStoredMarkup
|
|
, sfSheetExamAuthorshipStatementAllowOther :: Bool
|
|
}
|
|
|
|
mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm
|
|
mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
|
|
<$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh (textField & cfStrip & cfCI) (fslI MsgSchoolShort)
|
|
<*> areq (textField & cfStrip & cfCI) (fslI MsgSchoolName) (sfName <$> template)
|
|
<*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") MsgSchoolLdapOrganisationMissing (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template))
|
|
<* aformSection MsgSchoolExamSection
|
|
<*> aopt daysField (fslI MsgSchoolExamMinimumRegisterBeforeStart & setTooltip MsgSchoolExamMinimumRegisterBeforeStartTip) (sfExamMinimumRegisterBeforeStart <$> template)
|
|
<*> aopt daysField (fslI MsgSchoolExamMinimumRegisterDuration & setTooltip MsgSchoolExamMinimumRegisterDurationTip) (sfExamMinimumRegisterDuration <$> template)
|
|
<*> apopt checkBoxField (fslI MsgSchoolExamRequireModeForRegistration & setTooltip MsgSchoolExamRequireModeForRegistration) (sfExamRequireModeForRegistration <$> template)
|
|
<*> (fromMaybe (ExamModeDNF predDNFFalse) <$> aopt pathPieceField (fslI MsgSchoolExamDiscouragedModes) (Just $ sfExamDiscouragedModes <$> template <|> pure (ExamModeDNF predDNFFalse)))
|
|
<*> apopt (selectField optionsFinite) (fslI MsgExamCloseMode) (sfExamCloseMode <$> template <|> pure ExamCloseSeparate)
|
|
<* aformSection MsgSchoolAuthorshipStatementSection
|
|
<*> apopt (selectField optionsFinite) (fslI MsgSchoolAuthorshipStatementSheetMode) (sfSheetAuthorshipStatementMode <$> template <|> pure SchoolAuthorshipStatementModeOptional)
|
|
<*> i18nFieldA htmlField False (\_ -> Nothing) ("sheet-authorship-statement-definition" :: Text) (fslI MsgSchoolAuthorshipStatementSheetDefinition & setTooltip MsgSchoolAuthorshipStatementSheetDefinitionTip) False (sfSheetAuthorshipStatementDefinition <$> template)
|
|
<*> apopt checkBoxField (fslI MsgSchoolAuthorshipStatementSheetAllowOther) (sfSheetAuthorshipStatementAllowOther <$> template <|> pure True)
|
|
<*> apopt (selectField optionsFinite) (fslI MsgSchoolAuthorshipStatementSheetExamMode) (sfSheetExamAuthorshipStatementMode <$> template <|> pure SchoolAuthorshipStatementModeOptional)
|
|
<*> i18nFieldA htmlField False (\_ -> Nothing) ("exam-authorship-statement-definition" :: Text) (fslI MsgSchoolAuthorshipStatementSheetExamDefinition & setTooltip MsgSchoolAuthorshipStatementSheetExamDefinitionTip) False (sfSheetExamAuthorshipStatementDefinition <$> template)
|
|
<*> apopt checkBoxField (fslI MsgSchoolAuthorshipStatementSheetExamAllowOther) (sfSheetExamAuthorshipStatementAllowOther <$> template <|> pure True)
|
|
-- TODO(AuthorshipStatements): disallow not allowOther && is _Nothing definition
|
|
where
|
|
ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text))
|
|
ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
|
|
setOf (folded . _entityVal . _schoolLdapOrgUnit) <$> selectList [] []
|
|
|
|
schoolToForm :: SchoolId -> DB (Form SchoolForm)
|
|
schoolToForm ssh = do
|
|
School{..} <- get404 ssh
|
|
ldapFrags <- selectList [SchoolLdapSchool ==. Just ssh] []
|
|
|
|
mSheetAuthorshipStatementDefinition <- maybe (return Nothing) get schoolSheetAuthorshipStatementDefinition
|
|
mSheetExamAuthorshipStatementDefinition <- maybe (return Nothing) get schoolSheetExamAuthorshipStatementDefinition
|
|
|
|
return . mkSchoolForm (Just ssh) $ Just SchoolForm
|
|
{ sfShorthand = schoolShorthand
|
|
, sfName = schoolName
|
|
, sfOrgUnits = setOf (folded . _entityVal . _schoolLdapOrgUnit) ldapFrags
|
|
, sfExamMinimumRegisterBeforeStart = schoolExamMinimumRegisterBeforeStart
|
|
, sfExamMinimumRegisterDuration = schoolExamMinimumRegisterDuration
|
|
, sfExamRequireModeForRegistration = schoolExamRequireModeForRegistration
|
|
, sfExamDiscouragedModes = schoolExamDiscouragedModes
|
|
, sfExamCloseMode = schoolExamCloseMode
|
|
, sfSheetAuthorshipStatementMode = schoolSheetAuthorshipStatementMode
|
|
, sfSheetAuthorshipStatementDefinition = authorshipStatementDefinitionContent <$> mSheetAuthorshipStatementDefinition
|
|
, sfSheetAuthorshipStatementAllowOther = schoolSheetAuthorshipStatementAllowOther
|
|
, sfSheetExamAuthorshipStatementMode = schoolSheetExamAuthorshipStatementMode
|
|
, sfSheetExamAuthorshipStatementDefinition = authorshipStatementDefinitionContent <$> mSheetExamAuthorshipStatementDefinition
|
|
, sfSheetExamAuthorshipStatementAllowOther = schoolSheetExamAuthorshipStatementAllowOther
|
|
}
|
|
|
|
getSchoolEditR, postSchoolEditR :: SchoolId -> Handler Html
|
|
getSchoolEditR = postSchoolEditR
|
|
postSchoolEditR ssh = do
|
|
sForm <- runDB $ schoolToForm ssh
|
|
|
|
((sfResult, sfView), sfEnctype) <- runFormPost sForm
|
|
|
|
formResult sfResult $ \SchoolForm{..} -> do
|
|
runDB $ do
|
|
mSheetAuthorshipStatementId <- traverse insertAuthorshipStatement sfSheetAuthorshipStatementDefinition
|
|
mSheetExamAuthorshipStatementId <- traverse insertAuthorshipStatement sfSheetExamAuthorshipStatementDefinition
|
|
update ssh
|
|
[ SchoolName =. sfName
|
|
, SchoolExamMinimumRegisterBeforeStart =. sfExamMinimumRegisterBeforeStart
|
|
, SchoolExamMinimumRegisterDuration =. sfExamMinimumRegisterDuration
|
|
, SchoolExamRequireModeForRegistration =. sfExamRequireModeForRegistration
|
|
, SchoolExamDiscouragedModes =. sfExamDiscouragedModes
|
|
, SchoolExamCloseMode =. sfExamCloseMode
|
|
, SchoolSheetAuthorshipStatementMode =. sfSheetAuthorshipStatementMode
|
|
, SchoolSheetAuthorshipStatementDefinition =. mSheetAuthorshipStatementId
|
|
, SchoolSheetAuthorshipStatementAllowOther =. sfSheetAuthorshipStatementAllowOther
|
|
, SchoolSheetExamAuthorshipStatementMode =. sfSheetExamAuthorshipStatementMode
|
|
, SchoolSheetExamAuthorshipStatementDefinition =. mSheetExamAuthorshipStatementId
|
|
, SchoolSheetExamAuthorshipStatementAllowOther =. sfSheetExamAuthorshipStatementAllowOther
|
|
]
|
|
forM_ sfOrgUnits $ \schoolLdapOrgUnit ->
|
|
void $ upsert SchoolLdap
|
|
{ schoolLdapSchool = Just ssh
|
|
, ..
|
|
}
|
|
[ SchoolLdapSchool =. Just ssh
|
|
]
|
|
deleteWhere [SchoolLdapSchool ==. Just ssh, SchoolLdapOrgUnit /<-. Set.toList sfOrgUnits]
|
|
addMessageI Success $ MsgSchoolUpdated ssh
|
|
redirect $ SchoolR ssh SchoolEditR
|
|
|
|
let sfView' = wrapForm sfView FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ SchoolR ssh SchoolEditR
|
|
, formEncoding = sfEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Nothing :: Maybe Text
|
|
}
|
|
|
|
siteLayoutMsg (MsgSchoolTitle ssh) $ do
|
|
setTitleI $ MsgSchoolTitle ssh
|
|
sfView'
|
|
|
|
getSchoolNewR, postSchoolNewR :: Handler Html
|
|
getSchoolNewR = postSchoolNewR
|
|
postSchoolNewR = do
|
|
uid <- requireAuthId
|
|
((sfResult, sfView), sfEnctype) <- runFormPost $ mkSchoolForm Nothing Nothing
|
|
|
|
formResult sfResult $ \SchoolForm{..} -> do
|
|
let ssh = SchoolKey sfShorthand
|
|
insertOkay <- runDB $ do
|
|
mSheetAuthorshipStatementId <- traverse insertAuthorshipStatement sfSheetExamAuthorshipStatementDefinition
|
|
mSheetExamAuthorshipStatementId <- traverse insertAuthorshipStatement sfSheetExamAuthorshipStatementDefinition
|
|
didInsert <- is _Just <$> insertUnique School
|
|
{ schoolShorthand = sfShorthand
|
|
, schoolName = sfName
|
|
, schoolExamMinimumRegisterBeforeStart = sfExamMinimumRegisterBeforeStart
|
|
, schoolExamMinimumRegisterDuration = sfExamMinimumRegisterDuration
|
|
, schoolExamRequireModeForRegistration = sfExamRequireModeForRegistration
|
|
, schoolExamDiscouragedModes = sfExamDiscouragedModes
|
|
, schoolExamCloseMode = sfExamCloseMode
|
|
, schoolSheetAuthorshipStatementMode = sfSheetAuthorshipStatementMode
|
|
, schoolSheetAuthorshipStatementDefinition = mSheetAuthorshipStatementId
|
|
, schoolSheetAuthorshipStatementAllowOther = sfSheetAuthorshipStatementAllowOther
|
|
, schoolSheetExamAuthorshipStatementMode = sfSheetExamAuthorshipStatementMode
|
|
, schoolSheetExamAuthorshipStatementDefinition = mSheetExamAuthorshipStatementId
|
|
, schoolSheetExamAuthorshipStatementAllowOther = sfSheetExamAuthorshipStatementAllowOther
|
|
}
|
|
when didInsert $ do
|
|
insert_ UserFunction
|
|
{ userFunctionUser = uid
|
|
, userFunctionSchool = ssh
|
|
, userFunctionFunction = SchoolAdmin
|
|
}
|
|
forM_ sfOrgUnits $ \schoolLdapOrgUnit ->
|
|
void $ upsert SchoolLdap
|
|
{ schoolLdapSchool = Just ssh
|
|
, ..
|
|
}
|
|
[ SchoolLdapSchool =. Just ssh
|
|
]
|
|
return didInsert
|
|
|
|
if
|
|
| insertOkay -> do
|
|
addMessageI Success $ MsgSchoolCreated ssh
|
|
redirect $ SchoolR ssh SchoolEditR
|
|
| otherwise
|
|
-> addMessageI Error $ MsgSchoolExists ssh
|
|
|
|
let sfView' = wrapForm sfView FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just $ SomeRoute SchoolNewR
|
|
, formEncoding = sfEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Nothing :: Maybe Text
|
|
}
|
|
|
|
siteLayoutMsg MsgTitleSchoolNew $ do
|
|
setTitleI MsgTitleSchoolNew
|
|
sfView'
|