117 lines
4.6 KiB
Haskell
117 lines
4.6 KiB
Haskell
module Handler.ExamOffice.Fields
|
|
( getEOFieldsR
|
|
, postEOFieldsR
|
|
) where
|
|
|
|
import Import
|
|
import Utils.Form
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
data ExamOfficeFieldMode
|
|
= EOFNotSubscribed
|
|
| EOFSubscribed
|
|
| EOFForced
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
embedRenderMessage ''UniWorX ''ExamOfficeFieldMode $ concat . set (ix 0) "ExamOfficeField" . splitCamel
|
|
instance Universe ExamOfficeFieldMode
|
|
instance Finite ExamOfficeFieldMode
|
|
nullaryPathPiece ''ExamOfficeFieldMode $ camelToPathPiece' 1
|
|
instance Default ExamOfficeFieldMode where
|
|
def = EOFNotSubscribed
|
|
|
|
eofModeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m ExamOfficeFieldMode
|
|
-- ^ Always required
|
|
eofModeField = Field{..}
|
|
where
|
|
fieldEnctype = UrlEncoded
|
|
fieldView = \theId name attrs val _isReq -> $(widgetFile "widgets/fields/examOfficeFieldMode")
|
|
fieldParse = \e _ -> return $ parser e
|
|
|
|
parser [] = Right Nothing
|
|
parser (x:_)
|
|
| Just mode <- fromPathPiece x
|
|
= Right $ Just mode
|
|
parser (x:_)
|
|
= Left . SomeMessage $ MsgInvalidExamOfficeFieldMode x
|
|
|
|
isChecked :: Eq a => a -> Either Text a -> Bool
|
|
isChecked opt = either (const False) (== opt)
|
|
|
|
|
|
makeExamOfficeFieldsForm :: UserId -> Maybe (Map StudyTermsId Bool) -> Form (Map StudyTermsId Bool)
|
|
makeExamOfficeFieldsForm uid template = renderWForm FormStandard $ do
|
|
availableFields <- liftHandler . runDB . E.select . E.from $ \(terms `E.InnerJoin` schoolTerms) -> do
|
|
E.on $ terms E.^. StudyTermsId E.==. schoolTerms E.^. SchoolTermsTerms
|
|
E.where_ . E.exists . E.from $ \userFunction ->
|
|
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
|
|
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice
|
|
E.&&. userFunction E.^. UserFunctionSchool E.==. schoolTerms E.^. SchoolTermsSchool
|
|
return terms
|
|
let available = imap (\k terms -> (terms, view forced $ template >>= Map.lookup k)) $ toMapOf (folded .> _entityVal) availableFields
|
|
|
|
forced :: Iso' (Maybe Bool) ExamOfficeFieldMode
|
|
forced = iso fromForced toForced
|
|
where
|
|
fromForced = maybe EOFNotSubscribed $ bool EOFSubscribed EOFForced
|
|
toForced = \case
|
|
EOFNotSubscribed -> Nothing
|
|
EOFSubscribed -> Just False
|
|
EOFForced -> Just True
|
|
|
|
fmap (fmap (Map.mapMaybe $ review forced) . sequence) . forM available $ \(StudyTerms{..}, template')
|
|
-> let label = fromMaybe (tshow studyTermsKey) $ studyTermsName <|> studyTermsShorthand
|
|
in wpopt eofModeField (fsl label) $ Just template'
|
|
|
|
-- | Manage the list of `StudyTerms` this user (in her function as exam-office)
|
|
-- has an interest in, i.e. that authorize her to view an users grades, iff
|
|
-- they study one of the selected fields
|
|
getEOFieldsR, postEOFieldsR :: Handler Html
|
|
getEOFieldsR = postEOFieldsR
|
|
postEOFieldsR = do
|
|
uid <- requireAuthId
|
|
|
|
oldFields <- runDB $ do
|
|
fields <- E.select . E.from $ \examOfficeField -> do
|
|
E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val uid
|
|
return (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced)
|
|
return $ toMapOf (folded .> ito (over _1 E.unValue . over _2 E.unValue)) fields
|
|
|
|
((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields
|
|
|
|
formResult fieldsRes $ \newFields -> do
|
|
runDB . forM_ (Map.keysSet newFields `Set.union` Map.keysSet oldFields) $ \fieldId -> if
|
|
| Just forced <- Map.lookup fieldId newFields
|
|
, fieldId `Map.member` oldFields -> do
|
|
updateBy (UniqueExamOfficeField uid fieldId) [ ExamOfficeFieldForced =. forced ]
|
|
audit $ TransactionExamOfficeFieldEdit uid fieldId
|
|
| Just forced <- Map.lookup fieldId newFields -> do
|
|
insert_ $ ExamOfficeField uid fieldId forced
|
|
audit $ TransactionExamOfficeFieldEdit uid fieldId
|
|
| otherwise -> do
|
|
deleteBy $ UniqueExamOfficeField uid fieldId
|
|
audit $ TransactionExamOfficeFieldDelete uid fieldId
|
|
addMessageI Success $ MsgTransactionExamOfficeFieldsUpdated (Set.size . Set.map (view _1) $ (setSymmDiff `on` assocsSet) newFields oldFields)
|
|
redirect $ ExamOfficeR EOExamsR
|
|
|
|
let
|
|
fieldsView' = wrapForm fieldsView def
|
|
{ formAction = Just . SomeRoute $ ExamOfficeR EOFieldsR
|
|
, formEncoding = fieldsEnc
|
|
}
|
|
|
|
siteLayoutMsg MsgMenuExamOfficeFields $ do
|
|
setTitleI MsgMenuExamOfficeFields
|
|
|
|
[whamlet|
|
|
$newline never
|
|
<p>
|
|
_{MsgExamOfficeSubscribedFieldsExplanation}
|
|
^{fieldsView'}
|
|
|]
|
|
|