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

import Import

import Jobs.Queue

import Handler.Utils
import Handler.Utils.Invitations

import qualified Data.Conduit.List as C

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E

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


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


getSEditR, postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSEditR = postSEditR
postSEditR tid ssh csh shn = do
  (Entity sid Sheet{..}, sheetFileIds, currentLoads) <- runDB $ do
    ent@(Entity sid _) <- 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)
    return (ent, fti, cLoads)
  let template = Just $ SheetForm
        { sfName           = sheetName
        , sfDescription    = sheetDescription
        , sfType           = 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
        }

  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 newSheet = Sheet
              { sheetCourse         = cid
              , sheetName           = sfName
              , sheetDescription    = sfDescription
              , sheetType           = sfType
              , sheetGrouping       = sfGrouping
              , sheetMarkingText    = sfMarkingText
              , sheetVisibleFrom    = sfVisibleFrom
              , sheetActiveFrom     = sfActiveFrom
              , sheetActiveTo       = sfActiveTo
              , sheetHintFrom       = sfHintFrom
              , sheetSolutionFrom   = sfSolutionFrom
              , sheetSubmissionMode = sfSubmissionMode
              , sheetAutoDistribute = sfAutoDistribute
              , sheetAnonymousCorrection = sfAnonymousCorrection
              , sheetRequireExamRegistration = sfRequireExamRegistration
              }
        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 $ fromMaybe (return ()) sfSheetF
            insertSheetFile' sid SheetHint     $ fromMaybe (return ()) sfHintF
            insertSheetFile' sid SheetSolution $ fromMaybe (return ()) sfSolutionF
            insertSheetFile' sid SheetMarking  $ fromMaybe (return ()) sfMarkingF
            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

            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 fs = do
    oldFiles <- fmap (Map.fromList . map $(E.unValueN 2)) . E.select . E.from $ \sheetFile -> do
      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
           E.&&. sheetFile E.^. SheetFileType  E.==. E.val ftype
      return (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileId)
    keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ (finsert oldFiles)
    deleteWhere [ SheetFileSheet ==. sid, SheetFileType ==. ftype, SheetFileId <-. Set.toList (setOf folded oldFiles \\ keep) ]
  where
    finsert oldFiles fRef
      | Just sfId <- fileReferenceTitle fRef `Map.lookup` oldFiles
      = tell $ Set.singleton sfId
      | otherwise
      = do
          sfId <- lift . insert $ _FileReference # (fRef, SheetFileResidual sid ftype)
          tell $ Set.singleton sfId