module Handler.Submission.Assign
  ( getSubAssignR, postSubAssignR
  , getCAssignR, postCAssignR
  , getSAssignR, postSAssignR
  ) where

import Import hiding (link, unzip)

import Handler.Utils hiding (colSchool)
import Handler.Utils.Corrections
import Handler.Utils.Submission

import Data.List as List (foldl, foldr)
import qualified Data.Set as Set
import Data.Map.Strict ((!), (!?))
import qualified Data.Map.Strict as Map

import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI

import qualified Database.Esqueleto.Legacy as E

import Data.List.NonEmpty (unzip)


getSubAssignR, postSubAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getSubAssignR = postSubAssignR
postSubAssignR tid ssh csh shn cID = do
  let actionUrl = CSubmissionR tid ssh csh shn cID SubAssignR
  sId <- decrypt cID
  (currentCorrector, sheetCorrectors) <- runDB $ do
    Submission{submissionRatingBy, submissionSheet} <- get404 sId
    sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] []
    userCorrector <- traverse getJustEntity submissionRatingBy
    return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors)

  $logDebugS "SubAssignR" $ tshow currentCorrector
  let correctorField  = selectField $ optionsPersistCryptoId [UserId <-. sheetCorrectors] [Asc UserSurname, Asc UserDisplayName] userDisplayName
  ((corrResult, corrForm'), corrEncoding) <- runFormPost . renderAForm FormStandard $
        aopt correctorField (fslI MsgTableCorrector) (Just currentCorrector)
  formResult corrResult $ \(fmap entityKey -> mbUserId) -> do
    when (mbUserId /= fmap entityKey currentCorrector) . runDB $ do
      now <- liftIO getCurrentTime
      update sId  [ SubmissionRatingBy =. mbUserId
                  , SubmissionRatingAssigned =. (now <$ mbUserId)
                  ]
      addMessageI Success MsgCorrectorUpdated
      sub <- getJust sId
      audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet
    redirect actionUrl
  let corrForm = wrapForm' BtnSave corrForm' def
        { formAction = Just $ SomeRoute actionUrl
        , formEncoding = corrEncoding
        , formSubmit = FormSubmit
        }
  defaultLayout $ do
      setTitleI MsgCorrectorAssignTitle
      $(widgetFile "submission-assign")


getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCAssignR = postCAssignR
postCAssignR tid ssh csh = do
  cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh
  assignHandler tid ssh csh cid []

getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSAssignR = postSAssignR
postSAssignR tid ssh csh shn = do
  (shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn
  assignHandler tid ssh csh cid [shid]


assignHandler :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html
assignHandler tid ssh csh cid assignSids = do
  currentRoute <- fromMaybe (error "assignHandler called from 404-handler") <$> liftHandler getCurrentRoute

  -- gather data
  (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment, ((btnViews, btnCsrf), btnEncoding)) <- runDB $ do
      -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
      nrParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]

      sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
      assignSids' <- if
        | null assignSids -> -- assignAll; we distinguish assignSids' here avoid useless Alerts
            selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo]
        | otherwise -> return $ filter (`elem` map entityKey sheetList) assignSids

      let orderedSheetNames = fmap (\(Entity _ Sheet{sheetName}) -> sheetName) sheetList
          sheets = entities2map sheetList
          sheetIds = Map.keys sheets
          groupsPossible :: Bool
          groupsPossible =
            let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups
            in  List.foldr foldFun False sheetList
          assignSheetNames  = sheetName <$> mapMaybe (`Map.lookup` sheets) assignSids
          assignSheetNames' = sheetName <$> mapMaybe (`Map.lookup` sheets) assignSids'

          assignButtons = Map.fromSet (maybe BtnSubmissionsAssignAll BtnSubmissionsAssign) $ Set.fromList . bool (Nothing :) id (null sheetList) $ map Just assignSheetNames'

      ((btnResult, btnViews'), btnEncoding) <- runFormPost . identifyForm FIDAssignSubmissions $ \csrf ->
        fmap (over _1 (asum . fmap (hoistMaybe =<<)) . over _2 (, csrf) . unzip) . for assignButtons $ \btn -> mopt (buttonField btn) "" Nothing

      -- plan or assign unassigned submissions for given sheets
      let buildA :: Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational))
          buildA acc sid = maybeT (return acc) $ do
            let shn = sheetName $ sheets ! sid
            -- is sheet closed?
            guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh shn SAssignR  -- we must check, whether the submission is already closed and thus assignable
            -- ask for assignment plan
            let ignoreExceptions :: AssignSubmissionException -> DB (Map SubmissionId (Maybe UserId), Map UserId Rational) -- silently ignore errors, since we check all sheets and only care about sheets with unassigned corrections
                ignoreExceptions NoCorrectors             = return mempty
                ignoreExceptions NoCorrectorsByProportion = return mempty
                ignoreExceptions (SubmissionsNotFound _sids_not_found) = return mempty -- cannot happen, since last argument to planSubmissions is Nothing
            (plan,deficit) <- lift $ handle ignoreExceptions $ planSubmissions sid Nothing
            guard $ not $ null plan -- only proceed if there is a plan for this sheet
            status@(sub_ok, sub_fail) <- fmap fold . formResultMaybe btnResult $ \btn -> lift . maybeT (return Nothing) $ do
              guard $ case btn of
                BtnSubmissionsAssignAll      -> True
                BtnSubmissionsAssign    shn' -> shn' == shn

              status@(sub_ok,sub_fail) <- lift $ writeSubmissionPlan plan
              let nr_ok      = olength sub_ok
                  nr_fail    = olength sub_fail
                  alert_ok   = toMaybe (nr_ok   > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoAssigned nr_ok
                  alert_fail = toMaybe (nr_fail > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoFailed   nr_fail
                  msg_status = bool Success Error $ nr_fail > 0
                  msg_header = SomeMessage $ shn <> ":"
              if | nr_ok > 0 || nr_fail > 0 -> do
                     addMessageI msg_status $ UniWorXMessages $ msg_header : catMaybes [alert_ok, alert_fail]
                     return $ Just status
                 | otherwise -> do
                     addMessageI Error $ MsgSheetsUnassignable $ CI.original shn
                     return Nothing
            if | null sub_ok && null sub_fail ->
                   return $ Map.insert shn (status, countMapElems plan, deficit) acc
               | otherwise -> do
                   (plan', deficit') <- lift $ handle ignoreExceptions $ planSubmissions sid Nothing
                   return $ Map.insert shn (status, countMapElems plan', deficit') acc
      assignment <- foldM buildA Map.empty assignSids'

      correctors <- E.select . E.from $ \(corrector `E.InnerJoin` user) -> do
          E.on $ corrector E.^. SheetCorrectorUser E.==. user E.^. UserId
          E.where_ $ corrector E.^. SheetCorrectorSheet `E.in_` E.valList sheetIds
          return (corrector, user)
      let correctorMap' :: Map UserId (User, Map SheetName SheetCorrector)
          correctorMap' = (\f -> foldl f Map.empty correctors)
            (\acc (Entity _ sheetcorr@SheetCorrector{sheetCorrectorSheet}, Entity uid user) ->
                let shn = sheetName $ sheets ! sheetCorrectorSheet
                in  Map.insertWith (\(usr, ma) (_, mb) -> (usr, Map.union ma mb))  uid (user, Map.singleton shn sheetcorr) acc
            )
      -- Lecturers may correct without being enlisted SheetCorrectors, so fetch all names
      act_correctors <- E.select . E.distinct . E.from $ \(submission `E.InnerJoin` user) -> do
          E.on $ submission E.^. SubmissionRatingBy E.==. E.just (user E.^. UserId)
          E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
          return (submission E.^. SubmissionSheet, user)
      let correctorMap :: Map UserId (User, Map SheetName SheetCorrector)
          correctorMap = (\f -> foldl f correctorMap' act_correctors)
            (\acc (E.Value sheetCorrectorSheet, Entity uid user) ->
                let shn = sheetName $ sheets ! sheetCorrectorSheet
                    scr = SheetCorrector uid sheetCorrectorSheet mempty CorrectorExcused
                in  Map.insertWith (\_new old -> old) uid (user, Map.singleton shn scr) acc -- keep already known correctors unchanged
            )

      submissions <- E.select . E.from $ \submission -> do
          E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
          let numSubmittors = E.subSelectCount . E.from $ \subUser ->
                E.where_ $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
          return (submission, numSubmittors)
      -- prepare map
      let infoMap  :: Map SheetName (Map (Maybe UserId) CorrectionInfo)
          infoMap  = List.foldl (flip buildS) emptySheets submissions

          -- ensure that all sheets are shown, including those without any submissions
          emptySheets = foldl (\m sid -> Map.insert (sheetName $ sheets ! sid) emptyCorrs m) Map.empty sheetIds
          emptyCorrs  = foldl (\m uid -> let cic = Just uid in
                                         Map.insert cic mempty{ciCorrector=cic} m) Map.empty $ Map.keys correctorMap


          buildS :: (Entity Submission, E.Value Int64) -> Map SheetName (Map (Maybe UserId) CorrectionInfo) -> Map SheetName (Map (Maybe UserId) CorrectionInfo)
          buildS (Entity _sheetId Submission{..}, E.Value nrSbmtrs) m =
              let shnm    = sheetName $ sheets ! submissionSheet
                  corTime = diffUTCTime <$> submissionRatingTime <*> submissionRatingAssigned
                  cinf    = Map.singleton submissionRatingBy $ CorrectionInfo
                            { ciSubmittors  = fromIntegral nrSbmtrs
                            , ciSubmissions = 1
                            , ciAssigned    = maybe 0 (const 1) submissionRatingBy   -- only used in sheetMap
                            , ciCorrected   = maybe 0 (const 1) submissionRatingTime
                            , ciCorrector   = submissionRatingBy
                            , ciMin = corTime
                            , ciTot = corTime
                            , ciMax = corTime
                            }
              in Map.insertWith (Map.unionWith (<>)) shnm cinf m

      return (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment, (btnViews', btnEncoding))

  let -- infoMap  :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference
      -- create aggregate maps

      -- Always iterate over orderedSheetNames for consistent sorting!
      sheetMap :: Map SheetName CorrectionInfo
      sheetMap = Map.map fold infoMap

      sheetLoad :: Map SheetName Load
      sheetLoad = -- Map.unionsWith (<>) ((Map.filter () ) . snd) <$> Map.elems correctorMap)
        let buildSL acc (_user,mSnSc) = Map.foldlWithKey buildL acc mSnSc
            buildL acc s SheetCorrector{sheetCorrectorLoad=l, sheetCorrectorState=CorrectorNormal}
              = Map.insertWith (<>) s l acc
            buildL acc _ _ = acc
        in  Map.foldl buildSL Map.empty correctorMap

      deficitMap :: Map UserId Rational
      deficitMap = foldMap (view _3) assignment

      corrMap  :: Map (Maybe UserId) CorrectionInfo
      corrMap  = Map.unionsWith (<>) $ Map.elems infoMap

      corrInfos :: [CorrectionInfo]
      corrInfos = sortBy (compare `on` (byName . ciCorrector) ) $ Map.elems corrMap
        where byName Nothing    = Nothing
              byName (Just uid) = Map.lookup uid correctorMap
      corrMapSum :: CorrectionInfo
      corrMapSum = fold corrMap

  let -- whamlet convenience functions
      -- avoid nestes hamlet $maybe with duplicated $nothing
      getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector, Text)
      getCorrector (Just uid)
        | Just (User{..},loadMap) <- Map.lookup uid correctorMap
        = (nameEmailWidget userEmail userDisplayName userSurname, loadMap, userDisplayName)
        --  | Just (User{..} ) <- Map.lookup uid lecturerNames
        --  = (nameEmailWidget userEmail userDisplayName userSurname, mempty)  -- lecturers may also correct in rare cases
      getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty, mempty)
      -- avoid nestes hamlet $maybe with duplicated $nothing
      getCorrSheetStatus :: Maybe UserId -> SheetName -> Maybe CorrectionInfo
      getCorrSheetStatus corr shn
        | (Just smap) <- Map.lookup shn infoMap
        = Map.lookup corr smap
      getCorrSheetStatus _ _ = Nothing
      -- avoid nestes hamlet $maybe with duplicated $nothing
      getCorrNewAssignment :: Maybe UserId -> SheetName -> Maybe Int
      getCorrNewAssignment corr shn
        | (Just (_,cass,_)) <- Map.lookup shn assignment
        = Map.lookup corr cass
      getCorrNewAssignment _ _ = Nothing
      -- avoid nestes hamlet $maybe with duplicated $nothing
      getCorrDeficit :: Maybe UserId -> Maybe Rational
      getCorrDeficit (Just uid) = Map.lookup uid deficitMap
      getCorrDeficit _          = Nothing

      getLoadSum :: SheetName -> Text
      getLoadSum shn | (Just load) <- Map.lookup shn sheetLoad
                     = showCompactCorrectorLoad load CorrectorNormal
      getLoadSum  _  = mempty

      showDiffDays :: Maybe NominalDiffTime -> Text
      showDiffDays = foldMap formatDiffDays
      showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text
      showAvgsDays Nothing   _ = mempty
      showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n
  let headingShort = MsgHeadingCorrectionsAssign
      headingLong  = prependCourseTitle tid ssh csh MsgHeadingCorrectionsAssign

      unassignableSheets = filter (`Map.notMember` assignment) assignSheetNames
  unless (null unassignableSheets) $ addMessageI Warning $ MsgSheetsUnassignable $ Text.intercalate ", " $ fmap CI.original unassignableSheets

  siteLayoutMsg headingShort $ do
    setTitleI headingLong

    let doWrap wdgt
          | null btnViews = wdgt
          | otherwise = wrapForm (toWidget btnCsrf <> wdgt) def
              { formAction = Just . SomeRoute $ currentRoute
              , formEncoding = btnEncoding
              , formSubmit = FormNoSubmit
              }
        sheetBtnViews = Map.fromList [ (shn, btn) | (Just shn, btn) <- Map.toList btnViews, shn `elem` assignSheetNames' ]
        assignSheetNames' = Map.keys $ Map.filter (\(_, new, _) -> any (> 0) $ Map.delete Nothing new) assignment

    doWrap $(widgetFile "corrections-overview")


data ButtonSubmissionsAssign
  = BtnSubmissionsAssign SheetName
  | BtnSubmissionsAssignAll
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
derivePathPiece ''ButtonSubmissionsAssign (camelToPathPiece' 2) "--"

instance RenderMessage UniWorX ButtonSubmissionsAssign where
  renderMessage f ls = \case
    BtnSubmissionsAssign    _ -> mr MsgBtnSubmissionsAssign
    BtnSubmissionsAssignAll   -> mr MsgBtnSubmissionsAssignAll
    where mr = renderMessage f ls

instance Button UniWorX ButtonSubmissionsAssign where
  btnClasses _ = [BCIsButton, BCPrimary]
