fradrive/src/Handler/Sheet/Edit.hs

module Handler.Sheet.Edit
  ( getSEditR, postSEditR
  , handleSheetEdit
  ) where

import Import

import Jobs.Queue

import Handler.Utils
import Handler.Utils.Invitations

import qualified Data.Set as Set
import qualified Data.Map as Map


import Handler.Sheet.Form
import Handler.Sheet.CorrectorInvite
import Handler.Sheet.PersonalisedFiles


getSEditR, postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSEditR = postSEditR
postSEditR tid ssh csh shn = do
  (Entity sid Sheet{..}, sheetFileIds, currentLoads, hasPersonalisedFiles, mAuthorshipStatement) <- runDB $ do
    ent@(Entity sid oldSheet) <- fetchSheet tid ssh csh shn
    fti <- getFtIdMap $ entityKey ent
    cLoads <- Map.union
      <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (InvDBDataSheetCorrector sheetCorrectorLoad sheetCorrectorState, InvTokenDataSheetCorrector)) (selectList [ SheetCorrectorSheet ==. sid ] [])
      <*> fmap (fmap (, InvTokenDataSheetCorrector) . Map.mapKeysMonotonic Left) (sourceInvitationsF sid)
    hasPersonalisedFiles <- exists [ PersonalisedSheetFileSheet ==. sid ]
    -- TODO: update statement if school authorship statement was updated?
    -- mSchoolAuthorshipStatement <- runMaybeT $ do
    --   Entity _ School{..} <- MaybeT . getEntity $ ssh
    --   definitionId <- MaybeT . return $ schoolSheetAuthorshipStatementDefinition
    --   MaybeT . getEntity $ definitionId
    mAuthorshipStatement <- maybe (pure Nothing) getEntity (oldSheet ^. _sheetAuthorshipStatement)
    return (ent, fti, cLoads, hasPersonalisedFiles, mAuthorshipStatement)
  let template = Just $ SheetForm
        { sfName           = sheetName
        , sfDescription    = sheetDescription
        , sfType           = review _SqlKey <$> sheetType
        , sfGrouping       = sheetGrouping
        , sfVisibleFrom    = sheetVisibleFrom
        , sfActiveFrom     = sheetActiveFrom
        , sfActiveTo       = sheetActiveTo
        , sfSubmissionMode = sheetSubmissionMode
        , sfSheetF         = Just . yieldMany . Set.elems $ sheetFileIds SheetExercise
        , sfHintFrom       = sheetHintFrom
        , sfHintF          = Just . yieldMany . Set.elems $ sheetFileIds SheetHint
        , sfSolutionFrom   = sheetSolutionFrom
        , sfSolutionF      = Just . yieldMany . Set.elems $ sheetFileIds SheetSolution
        , sfMarkingF       = Just . yieldMany . Set.elems $ sheetFileIds SheetMarking
        , sfMarkingText    = sheetMarkingText
        , sfAutoDistribute = sheetAutoDistribute
        , sfAnonymousCorrection = sheetAnonymousCorrection
        , sfCorrectors     = currentLoads
        , sfRequireExamRegistration = sheetRequireExamRegistration
        , sfPersonalF      = guardOn (hasPersonalisedFiles || not sheetAllowNonPersonalisedSubmission) SheetPersonalisedFilesForm
          { spffFilesKeepExisting = hasPersonalisedFiles
          , spffAllowNonPersonalisedSubmission = sheetAllowNonPersonalisedSubmission
          , spffFiles = Nothing
          }
        , sfAuthorshipStatement = authorshipStatementDefinitionContent . entityVal <$> mAuthorshipStatement
        }

  let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead
  handleSheetEdit tid ssh csh (Just sid) template action

handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodJobDB UniWorX (Maybe SheetId)) -> Handler Html
handleSheetEdit tid ssh csh msId template dbAction = do
  let mbshn  = sfName <$> template
  aid  <- requireAuthId
  cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh
  ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm cid msId template
  case res of
    (FormSuccess SheetForm{..}) -> do
      saveOkay <- runDBJobs $ do
        actTime <- liftIO getCurrentTime

       -- let insertNewOrKeepStatement = \case
       --       -- statement disabled:
       --       Nothing -> pure Nothing
       --       -- use school preset (i.e. return the id of a *copy*):
       --       Just Nothing -> runMaybeT $ do
       --         Entity _ School{..} <- MaybeT . getEntity $ ssh
       --         schoolStatementId <- MaybeT . return $ schoolSheetAuthorshipStatementDefinition
       --         Entity _ AuthorshipStatementDefinition{..} <- MaybeT . getEntity $ schoolStatementId
       --         lift . insert $ AuthorshipStatementDefinition authorshipStatementDefinitionContent
       --       -- use custom statement:
       --       Just (Just newContent) -> do
       --         mOldAuthorshipStatement <- runMaybeT $ do
       --           sId <- MaybeT . return $ msId
       --           Entity _ Sheet{..} <- MaybeT . getEntity $ sId
       --           statementId <- MaybeT . return $ sheetAuthorshipStatement
       --           MaybeT . getEntity $ statementId
       --         if
       --           -- statement modified: insert new statement
       --           | maybe True ((/=) newContent . authorshipStatementDefinitionContent . entityVal) mOldAuthorshipStatement
       --           -> Just <$> (insert $ AuthorshipStatementDefinition newContent)
       --           -- statement not modified: return id of old statement
       --           | otherwise -> return $ entityKey <$> mOldAuthorshipStatement
       -- mNewAuthorshipStatementId <- insertNewOrKeepStatement sfAuthorshipStatement

        let newSheet = Sheet
              { sheetCourse         = cid
              , sheetName           = sfName
              , sheetDescription    = sfDescription
              , sheetType           = view _SqlKey <$> sfType
              , sheetGrouping       = sfGrouping
              , sheetMarkingText    = sfMarkingText
              , sheetVisibleFrom    = sfVisibleFrom
              , sheetActiveFrom     = sfActiveFrom
              , sheetActiveTo       = sfActiveTo
              , sheetHintFrom       = sfHintFrom
              , sheetSolutionFrom   = sfSolutionFrom
              , sheetSubmissionMode = sfSubmissionMode
              , sheetAutoDistribute = sfAutoDistribute
              , sheetAnonymousCorrection = sfAnonymousCorrection
              , sheetRequireExamRegistration = sfRequireExamRegistration
              , sheetAllowNonPersonalisedSubmission = maybe True spffAllowNonPersonalisedSubmission sfPersonalF
              , sheetAuthorshipStatement = Nothing  -- TODO: implement sheet-specific statements
              }
        mbsid <- dbAction newSheet
        case mbsid of
          Nothing    -> False <$ addMessageI Error (MsgSheetNameDup tid ssh csh sfName)
          (Just sid) ->  do -- save files in DB:
            insertSheetFile' sid SheetExercise $ maybeVoid sfSheetF
            insertSheetFile' sid SheetHint     $ maybeVoid sfHintF
            insertSheetFile' sid SheetSolution $ maybeVoid sfSolutionF
            insertSheetFile' sid SheetMarking  $ maybeVoid sfMarkingF
            runConduit $
                 maybe (return ()) (transPipe liftHandler) (spffFiles =<< sfPersonalF)
              .| sinkPersonalisedSheetFiles cid sid (maybe False spffFilesKeepExisting sfPersonalF)
            insert_ $ SheetEdit aid actTime sid
            addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
            -- Sanity checks generating warnings only, but not errors!
            hoist lift . warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
                [ (sfVisibleFrom,     MsgSheetVisibleFrom)
                , (sfActiveFrom,      MsgSheetActiveFrom)
                , (sfActiveTo,        MsgSheetActiveTo)
                , (sfHintFrom,        MsgSheetSolutionFromTip)
                , (sfSolutionFrom,    MsgSheetSolutionFrom)
                ] ]

            let
              sheetCorrectors :: Set (Either (Invitation' SheetCorrector) SheetCorrector)
              sheetCorrectors = Set.fromList . map f $ Map.toList sfCorrectors
                where
                  f (Left email, invData) = Left (email, sid, invData)
                  f (Right uid, (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)) = Right $ SheetCorrector uid sid load cState
              (invites, adds) = partitionEithers $ Set.toList sheetCorrectors

            deleteWhere [ SheetCorrectorSheet ==. sid ]
            insertMany_ adds
            memcachedByInvalidate AuthCacheCorrectorList (Proxy @(Set UserId))

            deleteWhere [InvitationFor ==. invRef @SheetCorrector sid, InvitationEmail /<-. toListOf (folded . _1) invites]
            sinkInvitationsF correctorInvitationConfig invites

            return True
      when saveOkay $
        redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
    (FormFailure msgs) -> forM_ msgs $ addMessage Error . toHtml
    _ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
            [(sfVisibleFrom  =<< template, MsgSheetVisibleFrom)
            ,(sfActiveFrom   =<< template, MsgSheetActiveFrom)
            ,(sfActiveTo     =<< template, MsgSheetActiveTo)
            ,(sfHintFrom     =<< template, MsgSheetSolutionFromTip)
            ,(sfSolutionFrom =<< template, MsgSheetSolutionFrom)
            ] ]

  let pageTitle = maybe (MsgSheetTitleNew tid ssh csh)
                        (MsgSheetTitle    tid ssh csh) mbshn
--   let formTitle = pageTitle -- no longer used in template
  actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute
  defaultLayout $ do
    setTitleI pageTitle
    let sheetEditForm = wrapForm formWidget def
          { formAction = Just $ SomeRoute actionUrl
          , formEncoding = formEnctype
          }
    $(i18nWidgetFile "sheet-edit")

insertSheetFile' :: SheetId -> SheetFileType -> FileUploads -> YesodJobDB UniWorX ()
insertSheetFile' sid ftype = (void . ) . replaceFileReferences mkFilter $ SheetFileResidual sid ftype
  where mkFilter SheetFileResidual{..} = [ SheetFileSheet ==. sheetFileResidualSheet, SheetFileType ==. sheetFileResidualType ]