101 lines
4.5 KiB
Haskell
101 lines
4.5 KiB
Haskell
module Handler.Sheet.New
|
|
( getSheetNewR, postSheetNewR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
import Data.Time.Clock.System (systemEpochDay)
|
|
|
|
|
|
import Handler.Sheet.CorrectorInvite
|
|
import Handler.Sheet.Form
|
|
import Handler.Sheet.Edit
|
|
|
|
|
|
getSheetNewR, postSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getSheetNewR = postSheetNewR
|
|
postSheetNewR tid ssh csh = do
|
|
parShn <- runInputGetResult $ iopt ciField "shn"
|
|
let searchShn sheet = case parShn of
|
|
(FormSuccess (Just shn)) -> E.where_ $ sheet E.^. SheetName E.==. E.val shn
|
|
_other -> return ()
|
|
(lastSheets, loads) <- runDB $ do
|
|
lSheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
searchShn sheet
|
|
E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
|
|
E.limit 1
|
|
let
|
|
firstEdit = E.subSelectMaybe . E.from $ \sheetEdit -> do
|
|
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
|
return . E.min_ $ sheetEdit E.^. SheetEditTime
|
|
-- mAuthorshipStatement = E.subSelect . E.from $ \authorshipStatementDefinition -> do
|
|
-- E.where_ $ E.just (authorshipStatementDefinition E.^. AuthorshipStatementDefinitionId) E.==. sheet E.^. SheetAuthorshipStatement
|
|
-- return $ authorshipStatementDefinition E.^. AuthorshipStatementDefinitionContent
|
|
return (sheet, firstEdit)
|
|
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
loads <- defaultLoads cid
|
|
return (lSheets, loads)
|
|
now <- liftIO getCurrentTime
|
|
let template = case lastSheets of
|
|
((Entity {entityVal=Sheet{..}}, E.Value fEdit):_) ->
|
|
let addTime = addWeeks $ max 1 $ weeksToAdd (fromMaybe (UTCTime systemEpochDay 0) $ sheetActiveTo <|> fEdit) now
|
|
in Just $ SheetForm
|
|
{ sfName = stepTextCounterCI sheetName
|
|
, sfDescription = sheetDescription
|
|
, sfType = review _SqlKey <$> sheetType
|
|
, sfGrouping = sheetGrouping
|
|
, sfVisibleFrom = addTime <$> sheetVisibleFrom
|
|
, sfActiveFrom = addTime <$> sheetActiveFrom
|
|
, sfActiveTo = addTime <$> sheetActiveTo
|
|
, sfSubmissionMode = sheetSubmissionMode
|
|
, sfSheetF = Nothing
|
|
, sfHintFrom = addTime <$> sheetHintFrom
|
|
, sfHintF = Nothing
|
|
, sfSolutionFrom = addTime <$> sheetSolutionFrom
|
|
, sfSolutionF = Nothing
|
|
, sfMarkingF = Nothing
|
|
, sfMarkingText = sheetMarkingText
|
|
, sfAutoDistribute = sheetAutoDistribute
|
|
, sfCorrectors = loads
|
|
, sfAnonymousCorrection = sheetAnonymousCorrection
|
|
, sfRequireExamRegistration = Nothing
|
|
, sfPersonalF = Nothing
|
|
-- , sfAuthorshipStatement = mAuthorshipStatement
|
|
}
|
|
_other -> Nothing
|
|
let action = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
|
|
insertUnique
|
|
handleSheetEdit tid ssh csh Nothing template action
|
|
|
|
defaultLoads :: CourseId -> DB Loads
|
|
-- ^ Generate `Loads` in such a way that minimal editing is required
|
|
--
|
|
-- For every user, that ever was a corrector for this course, return their last `Load`.
|
|
-- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit).
|
|
defaultLoads cId =
|
|
fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do
|
|
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
|
|
|
let creationTime = E.subSelectMaybe . E.from $ \sheetEdit -> do
|
|
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
|
return . E.min_ $ sheetEdit E.^. SheetEditTime
|
|
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cId
|
|
|
|
E.orderBy [E.desc creationTime]
|
|
|
|
return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
|
|
where
|
|
toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
|
|
toMap = foldMap $ \(E.Value uid, E.Value cLoad, E.Value cState) -> Map.singleton (Right uid) (InvDBDataSheetCorrector cLoad cState, InvTokenDataSheetCorrector)
|