|
|
|
|
@ -25,6 +25,7 @@ import qualified Data.Text as T
|
|
|
|
|
--
|
|
|
|
|
import Colonnade hiding (fromMaybe, singleton)
|
|
|
|
|
import Yesod.Colonnade
|
|
|
|
|
import Text.Blaze (text)
|
|
|
|
|
--
|
|
|
|
|
import qualified Data.UUID.Cryptographic as UUID
|
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
|
@ -33,12 +34,15 @@ import qualified Database.Esqueleto as E
|
|
|
|
|
import qualified Database.Esqueleto.Internal.Sql as E
|
|
|
|
|
|
|
|
|
|
import Control.Monad.Writer (MonadWriter(..), execWriterT)
|
|
|
|
|
import Control.Monad.Trans.RWS.Lazy (RWST)
|
|
|
|
|
import Control.Monad.Trans.RWS.Lazy (RWST, local)
|
|
|
|
|
|
|
|
|
|
import qualified Text.Email.Validate as Email
|
|
|
|
|
|
|
|
|
|
import qualified Data.List as List
|
|
|
|
|
|
|
|
|
|
import Network.Mime
|
|
|
|
|
|
|
|
|
|
import Data.Set (Set)
|
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
|
|
|
|
|
|
import Data.Map (Map, (!), (!?))
|
|
|
|
|
@ -413,7 +417,7 @@ data CorrectorForm = CorrectorForm
|
|
|
|
|
{ cfUserId :: UserId
|
|
|
|
|
, cfUserName :: Text
|
|
|
|
|
, cfResult :: FormResult Load
|
|
|
|
|
, cfViewByTut, cfViewCountTut, cfViewProp :: FieldView UniWorX
|
|
|
|
|
, cfViewByTut, cfViewProp, cfViewDel :: FieldView UniWorX
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
type Loads = Map UserId Load
|
|
|
|
|
@ -438,17 +442,46 @@ defaultLoads shid = fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheet
|
|
|
|
|
toMap = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid load
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
correctorForm :: SheetId -> MForm Handler (FormResult Loads, [FieldView UniWorX])
|
|
|
|
|
correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX])
|
|
|
|
|
correctorForm shid = do
|
|
|
|
|
cListIdent <- newFormIdent
|
|
|
|
|
formCIDs <- lift $ mapM decrypt =<< (catMaybes . map fromPathPiece <$> lookupPostParams cListIdent :: Handler [CryptoUUIDUser])
|
|
|
|
|
let
|
|
|
|
|
guardNonDeleted :: CryptoUUIDUser -> Handler (Maybe CryptoUUIDUser)
|
|
|
|
|
guardNonDeleted cID@CryptoID{..} = do
|
|
|
|
|
deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del"
|
|
|
|
|
case deleted of
|
|
|
|
|
Just _ -> return Nothing
|
|
|
|
|
Nothing -> return $ Just cID
|
|
|
|
|
formCIDs <- lift $ (mapM decrypt <=< fmap catMaybes . mapM (maybe (return Nothing) guardNonDeleted)) =<< (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
|
|
|
|
|
loads'' <- lift . runDB $ defaultLoads shid
|
|
|
|
|
let loads' = loads'' `Map.union` Map.fromList [(uid, mempty) | uid <- formCIDs]
|
|
|
|
|
|
|
|
|
|
(addTutRes, addTutView) <- mopt emailField (fsm MsgAddCorrector) (Just Nothing)
|
|
|
|
|
(countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) Nothing
|
|
|
|
|
let
|
|
|
|
|
tutorField :: Field Handler [Text]
|
|
|
|
|
tutorField = multiEmailField
|
|
|
|
|
{ fieldView = \theId name attrs val isReq -> asWidgetT $ do
|
|
|
|
|
listIdent <- newIdent
|
|
|
|
|
userId <- handlerToWidget requireAuthId
|
|
|
|
|
previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do
|
|
|
|
|
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
|
|
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
|
|
|
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
|
|
|
|
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
|
|
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
|
|
|
|
|
return $ user E.^. UserEmail
|
|
|
|
|
toWidget [hamlet|
|
|
|
|
|
$newline never
|
|
|
|
|
<input id=#{theId} name=#{name} list=#{listIdent} *{attrs} type=email multiple :isReq:required value="">
|
|
|
|
|
<datalist id=#{listIdent}>
|
|
|
|
|
$forall E.Value prev <- previousCorrectors
|
|
|
|
|
<option value=#{prev}>
|
|
|
|
|
|]
|
|
|
|
|
}
|
|
|
|
|
(addTutRes, addTutView) <- mopt tutorField (fsm MsgAddCorrector) (Just Nothing)
|
|
|
|
|
|
|
|
|
|
loads <- case addTutRes of
|
|
|
|
|
FormSuccess (Just email) -> do
|
|
|
|
|
FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do
|
|
|
|
|
mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email)
|
|
|
|
|
case mUid of
|
|
|
|
|
Nothing -> loads' <$ addMessageI "error" (MsgEMailUnknown email)
|
|
|
|
|
@ -473,8 +506,8 @@ correctorForm shid = do
|
|
|
|
|
rationalField = convertField toRational fromRational doubleField
|
|
|
|
|
|
|
|
|
|
(byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
|
|
|
|
|
(countTutRes, cfViewCountTut) <- mreq checkBoxField (fs "counttut") byTutorial
|
|
|
|
|
(propRes, cfViewProp) <- mreq rationalField (fs "prop") (Just byProportion)
|
|
|
|
|
(propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
|
|
|
|
|
(_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
|
|
|
|
|
let
|
|
|
|
|
cfResult :: FormResult Load
|
|
|
|
|
cfResult = Load <$> tutRes' <*> propRes
|
|
|
|
|
@ -487,24 +520,28 @@ correctorForm shid = do
|
|
|
|
|
|
|
|
|
|
corrData <- sequence . catMaybes . (flip map) (Map.keys loads) $ \uid -> fmap constructFields $ (,,) <$> pure uid <*> names !? uid <*> loads !? uid
|
|
|
|
|
|
|
|
|
|
mr <- getMessageRender
|
|
|
|
|
|
|
|
|
|
let
|
|
|
|
|
corrColonnade = mconcat
|
|
|
|
|
[ headed "Korrektor" $ \CorrectorForm{..} -> textCell cfUserName
|
|
|
|
|
, headed "Nach Tutorium" $ \CorrectorForm{..} -> cell $ fvInput cfViewByTut
|
|
|
|
|
, headed "Tutorium zählt gegen Proportion" $ \CorrectorForm{..} -> cell $ fvInput cfViewCountTut -- TODO: set this once for entire sheet?
|
|
|
|
|
, headed "Proportion" $ \CorrectorForm{..} -> cell $ fvInput cfViewProp
|
|
|
|
|
[ headed (textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> textCell cfUserName
|
|
|
|
|
, headed (textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> cell $ fvInput cfViewByTut
|
|
|
|
|
, headed (textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> cell $ fvInput cfViewProp
|
|
|
|
|
, headed (textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> cell $ fvInput cfViewDel
|
|
|
|
|
]
|
|
|
|
|
corrResults
|
|
|
|
|
| FormSuccess _ <- addTutRes = FormMissing
|
|
|
|
|
| otherwise = fmap Map.fromList $ sequenceA [ (,) <$> pure cfUserId <*> cfResult
|
|
|
|
|
| FormSuccess (Just es) <- addTutRes
|
|
|
|
|
, not $ null es = FormMissing
|
|
|
|
|
| otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> cfResult
|
|
|
|
|
| CorrectorForm{..} <- corrData
|
|
|
|
|
]
|
|
|
|
|
idField CorrectorForm{..} = do
|
|
|
|
|
cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
|
|
|
|
|
toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
|
|
|
|
|
|
|
|
|
|
return (corrResults, [ FieldView
|
|
|
|
|
{ fvLabel = mempty
|
|
|
|
|
return (corrResults, [ countTutView
|
|
|
|
|
, FieldView
|
|
|
|
|
{ fvLabel = text $ mr MsgCorrectors
|
|
|
|
|
, fvTooltip = Nothing
|
|
|
|
|
, fvId = ""
|
|
|
|
|
, fvInput = encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData
|
|
|
|
|
@ -527,7 +564,15 @@ postSheetCorrectorsR = getSheetCorrectorsR
|
|
|
|
|
getSheetCorrectorsR tid@(unTermKey -> tident) csh shn = do
|
|
|
|
|
Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn
|
|
|
|
|
|
|
|
|
|
((res,formWidget), formEnctype) <- runFormPost . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
|
|
|
|
|
((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
|
|
|
|
|
|
|
|
|
|
case res of
|
|
|
|
|
FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
|
|
|
|
|
FormSuccess res -> runDB $ do
|
|
|
|
|
deleteWhere [SheetCorrectorSheet ==. shid]
|
|
|
|
|
insertMany_ $ Set.toList res
|
|
|
|
|
addMessageI "success" MsgCorrectorsUpdated
|
|
|
|
|
FormMissing -> return ()
|
|
|
|
|
|
|
|
|
|
let
|
|
|
|
|
formTitle = MsgSheetCorrectorsTitle tident csh shn
|
|
|
|
|
|
Gregor Kleen