100 lines
5.1 KiB
Haskell
100 lines
5.1 KiB
Haskell
module Handler.Tutorial.Form
|
|
( TutorialForm(..)
|
|
, tutorialForm
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Handler.Utils.Form.Occurrences
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import Data.Map ((!))
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
|
|
data TutorialForm = TutorialForm
|
|
{ tfName :: TutorialName
|
|
, tfType :: CI Text
|
|
, tfRegGroup :: Maybe (CI Text)
|
|
, tfTutorControlled :: Bool
|
|
, tfCapacity :: Maybe Int
|
|
, tfRoom :: Maybe Text
|
|
, tfTime :: Occurrences
|
|
, tfRegisterFrom :: Maybe UTCTime
|
|
, tfRegisterTo :: Maybe UTCTime
|
|
, tfDeregisterUntil :: Maybe UTCTime
|
|
, tfTutors :: Set (Either UserEmail UserId)
|
|
}
|
|
|
|
tutorialForm :: CourseId -> Maybe TutorialForm -> Form TutorialForm
|
|
tutorialForm cid template html = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
cRoute <- fromMaybe (error "tutorialForm called from 404-Handler") <$> getCurrentRoute
|
|
uid <- liftHandler requireAuthId
|
|
|
|
let
|
|
tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors) False (Set.toList . tfTutors <$> template)
|
|
where
|
|
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
|
|
miAdd' nudge submitView csrf = do
|
|
(addRes, addView) <- mpreq (multiUserField False . Just $ tutUserSuggestions uid) ("" & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
|
|
let
|
|
addRes'
|
|
| otherwise
|
|
= addRes <&> \newDat oldDat -> if
|
|
| existing <- newDat `Set.intersection` Set.fromList oldDat
|
|
, not $ Set.null existing
|
|
-> FormFailure [mr MsgTutorialTutorAlreadyAdded]
|
|
| otherwise
|
|
-> FormSuccess $ Set.toList newDat
|
|
return (addRes', $(widgetFile "tutorial/tutorMassInput/add"))
|
|
|
|
|
|
miCell' :: Either UserEmail UserId -> Widget
|
|
miCell' (Left email) = do
|
|
invWarnMsg <- messageI Warning MsgEmailInvitationWarning
|
|
$(widgetFile "tutorial/tutorMassInput/cellInvitation")
|
|
miCell' (Right userId) = do
|
|
User{..} <- liftHandler . runDB $ get404 userId
|
|
$(widgetFile "tutorial/tutorMassInput/cellKnown")
|
|
|
|
miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
|
|
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "tutorial/tutorMassInput/layout")
|
|
|
|
flip (renderAForm FormStandard) html $ TutorialForm
|
|
<$> areq (textField & cfStrip & cfCI) (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template)
|
|
<*> areq (textField & cfStrip & cfCI & addDatalist tutTypeDatalist) (fslpI MsgTutorialType (mr MsgTutorialTypePlaceholder) & setTooltip MsgTutorialTypeTip) (tfType <$> template)
|
|
<*> aopt (textField & cfStrip & cfCI) (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial"))
|
|
<*> apopt checkBoxField (fslI MsgTutorialTutorControlled & setTooltip MsgTutorialTutorControlledTip) (tfTutorControlled <$> template)
|
|
<*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template)
|
|
<*> (assertM (not . null) <$> aopt (textField & cfStrip) (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template))
|
|
<*> occurrencesAForm ("occurrences" :: Text) (tfTime <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate)
|
|
& setTooltip MsgCourseRegisterFromTip
|
|
) (tfRegisterFrom <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgRegisterTo (mr MsgDate)
|
|
& setTooltip MsgCourseRegisterToTip
|
|
) (tfRegisterTo <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgDeRegUntil (mr MsgDate)
|
|
& setTooltip MsgCourseDeregisterUntilTip
|
|
) (tfDeregisterUntil <$> template)
|
|
<*> tutorForm
|
|
where
|
|
tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text))
|
|
tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
|
|
fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
|
|
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
|
return $ tutorial E.^. TutorialType
|
|
|
|
tutUserSuggestions :: UserId -> E.SqlQuery (E.SqlExpr (Entity User))
|
|
tutUserSuggestions uid = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` tutorial `E.InnerJoin` tutor `E.InnerJoin` tutorUser) -> do
|
|
E.on $ tutorUser E.^. UserId E.==. tutor E.^. TutorUser
|
|
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
|
E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId
|
|
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
|
|
return tutorUser
|