123 lines
6.6 KiB
Haskell
123 lines
6.6 KiB
Haskell
module Handler.ExternalExam.Form
|
|
( ExternalExamForm(..)
|
|
, externalExamForm
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
|
|
import Handler.ExternalExam.StaffInvite ()
|
|
|
|
import qualified Data.Set as Set
|
|
import Data.Map ((!))
|
|
|
|
import qualified Control.Monad.State.Class as State
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
|
|
|
|
data ExternalExamForm = ExternalExamForm
|
|
{ eefTerm :: TermId
|
|
, eefSchool :: SchoolId
|
|
, eefCourseName :: CI Text
|
|
, eefExamName :: CI Text
|
|
, eefDefaultTime :: Maybe UTCTime
|
|
, eefGradingMode :: ExamGradingMode
|
|
, eefOfficeSchools :: Set SchoolId
|
|
, eefStaff :: Set (Either UserEmail UserId)
|
|
}
|
|
|
|
makeLenses_ ''ExternalExamForm
|
|
|
|
externalExamForm :: Maybe ExternalExamForm -> Form ExternalExamForm
|
|
externalExamForm template = validateForm validateExternalExam $ \html -> do
|
|
uid <- requireAuthId
|
|
cRoute <- fromMaybe (error "tutorialForm called from 404-Handler") <$> getCurrentRoute
|
|
MsgRenderer mr <- getMsgRenderer
|
|
allSchoolIds <- fmap (map E.unValue) . liftHandler . runDBRead . E.select . E.from $ return . (E.^. SchoolId)
|
|
|
|
let termsField = case template of
|
|
Just template' -> termsSetField [eefTerm template']
|
|
_other -> termsAllowedField
|
|
|
|
(lecturerSchools, adminSchools, oldSchool) <- liftHandler . runDB $ do
|
|
lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
|
|
protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] []
|
|
adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools
|
|
let oldSchool = eefSchool <$> template
|
|
return (lecturerSchools, adminSchools, oldSchool)
|
|
let userSchools = nubOrd . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools
|
|
templateSchool = eefSchool <$> template <|> case userSchools of
|
|
[ssh] -> pure ssh
|
|
_ -> mzero
|
|
|
|
flip (renderAForm FormStandard) html $ ExternalExamForm
|
|
<$> areq termsField (fslI MsgExternalExamSemester) (eefTerm <$> template)
|
|
<*> areq (schoolFieldFor userSchools) (fslI MsgExternalExamSchool) (eefSchool <$> template)
|
|
<*> areq (textField & cfStrip & cfCI) (fslI MsgExternalExamCourseName & setTooltip MsgExternalExamCourseNameTip & addPlaceholder (mr MsgExternalExamCourseNamePlaceholder)) (eefCourseName <$> template)
|
|
<*> areq (textField & cfStrip & cfCI) (fslI MsgExternalExamExamName & setTooltip MsgExternalExamExamNameTip & addPlaceholder (mr MsgExternalExamExamNamePlaceholder)) (eefExamName <$> template)
|
|
<*> aopt utcTimeField (fslI MsgExternalExamDefaultTime & setTooltip MsgExternalExamDefaultTimeTip & addPlaceholder (mr MsgExternalExamDefaultTimePlaceholder)) (eefDefaultTime <$> template)
|
|
<*> apopt (selectField optionsFinite) (fslI MsgExternalExamGradingMode & setTooltip MsgExternalExamGradingModeTip) (eefGradingMode <$> template <|> Just ExamGradingMixed)
|
|
<*> (Set.fromList <$> officeSchoolForm cRoute (Set.toList . eefOfficeSchools <$> template <|> Just (filter ((/= templateSchool) . Just) allSchoolIds)))
|
|
<*> (Set.fromList <$> staffForm cRoute ((Set.toList . eefStaff <$> template) <|> pure (pure $ Right uid)))
|
|
where
|
|
officeSchoolForm cRoute = massInputAccumA miAdd miCell miButtonAction miLayout miIdent fSettings fRequired
|
|
where
|
|
miAdd mkUnique submitView csrf = do
|
|
(schoolRes, addView) <- mpopt schoolField ("" & addName (mkUnique "school")) Nothing
|
|
let schoolRes' = schoolRes <&> \newDat oldDat -> FormSuccess (guardOn (newDat `notElem` oldDat) newDat)
|
|
return (schoolRes', $(widgetFile "external-exam/schoolMassInput/add"))
|
|
miCell ssh = do
|
|
School{..} <- liftHandler . runDB $ getJust ssh
|
|
$(widgetFile "external-exam/schoolMassInput/cell")
|
|
miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
|
miButtonAction = Just . SomeRoute . (cRoute :#:)
|
|
miLayout :: MassInputLayout ListLength SchoolId ()
|
|
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "external-exam/schoolMassInput/layout")
|
|
miIdent :: Text
|
|
miIdent = "external-exams-school"
|
|
fSettings = fslI MsgExternalExamExamOfficeSchools & setTooltip MsgExternalExamExamOfficeSchoolsTip
|
|
fRequired = False
|
|
staffForm :: Route UniWorX -> Maybe [Either UserEmail UserId] -> AForm Handler [Either UserEmail UserId]
|
|
staffForm cRoute = massInputAccumA miAdd miCell miButtonAction miLayout miIdent fSettings fRequired
|
|
where
|
|
miAdd mkUnique submitView csrf = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
(usersRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgExternalExamStaffEmail & addName (mkUnique "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
|
|
let
|
|
usersRes' = usersRes <&> \newDat oldDat -> if
|
|
| existing <- newDat `Set.intersection` Set.fromList oldDat
|
|
, not $ Set.null existing
|
|
-> FormFailure [mr MsgExternalExamStaffAlreadyAdded]
|
|
| otherwise
|
|
-> FormSuccess $ Set.toList newDat
|
|
return (usersRes', $(widgetFile "external-exam/staffMassInput/add"))
|
|
miCell (Left email) = do
|
|
invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
|
|
$(widgetFile "external-exam/staffMassInput/cellInvitation")
|
|
miCell (Right userId) = do
|
|
User{..} <- liftHandler . runDB $ getJust userId
|
|
$(widgetFile "external-exam/staffMassInput/cellKnown")
|
|
miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
|
miButtonAction = Just . SomeRoute . (cRoute :#:)
|
|
miLayout :: MassInputLayout ListLength (Either UserEmail UserId) ()
|
|
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "external-exam/staffMassInput/layout")
|
|
miIdent :: Text
|
|
miIdent = "external-exams-staff"
|
|
fSettings = fslI MsgExternalExamStaff & setTooltip MsgExternalExamStaffTip
|
|
fRequired = True
|
|
|
|
validateExternalExam :: (MonadThrow m, MonadAP m) => FormValidator ExternalExamForm m ()
|
|
validateExternalExam = do
|
|
State.modify $ \eeForm -> eeForm & over _eefOfficeSchools (Set.delete $ eeForm ^. _eefSchool)
|
|
|
|
ExternalExamForm{..} <- State.get
|
|
|
|
isAdmin <- lift . hasWriteAccessTo $ SchoolR eefSchool SchoolEditR
|
|
unless isAdmin $ do
|
|
uid <- requireAuthId
|
|
guardValidation MsgExternalExamUserMustBeStaff $ Right uid `Set.member` eefStaff
|
|
|
|
courseExists <- liftHandler . runDB . existsBy $ TermSchoolCourseName eefTerm eefSchool eefCourseName
|
|
guardValidation MsgExternalExamCourseExists $ not courseExists
|