module Handler.Submission.Create
  ( getCorrectionsCreateR, postCorrectionsCreateR
  ) where

import Import hiding (link)
-- import System.FilePath (takeFileName)

import Jobs
import Handler.Utils hiding (colSchool)

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 Control.Monad.State.Class as State

import qualified Database.Esqueleto as E

import Data.List (genericLength)


getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html
getCorrectionsCreateR = postCorrectionsCreateR
postCorrectionsCreateR = do
  uid <- requireAuthId
  let sheetOptions = mkOptList . toListOf (traverse . filtered (view $ _1 . _Value . _submissionModeCorrector) . _2) <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
        E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
        let
          isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_
                $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
            E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
          isLecturer = E.exists . E.from $ \lecturer -> E.where_
                $ lecturer E.^. LecturerUser E.==. E.val uid
            E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
        E.where_ $ isCorrector E.||. isLecturer
        E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom]
        return (sheet E.^. SheetSubmissionMode, (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName))
      mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId)
      mkOptList opts = do
        opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts
        MsgRenderer mr <- getMsgRenderer
        return . mkOptionList $ do
          (cID, (E.Value sid, E.Value tid, E.Value csh, E.Value shn)) <- opts'
          let tid' = mr $ ShortTermIdentifier (unTermKey tid)
          return Option
            { optionDisplay = mr $ MsgCorrectionPseudonymSheet tid' csh shn
            , optionInternalValue = sid
            , optionExternalValue = toPathPiece (cID :: CryptoUUIDSheet)
            }
  MsgRenderer mr <- getMsgRenderer
  ((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,)
    <$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing
    <*> (textToList <$> areq textareaField (fslpI MsgCorrectionPseudonyms (mr MsgPseudonyms) & setTooltip MsgCorrectionPseudonymsTip) Nothing)

  case pseudonymRes of
    FormMissing -> return ()
    FormFailure errs -> forM_ errs $ addMessage Error . toHtml
    FormSuccess (sid, (pss, invalids)) -> do
      allDone <- fmap getAll . execWriterT $ do
        forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet")
        tell . All $ null invalids

        WriterT . runDBJobs . mapReaderT (mapWriterT $ fmap ((,) <$> ((,) <$> view (_1 . _1) <*> view _2) <*> view (_1 . _2)) . runWriterT) $ do
          Sheet{..} <- get404 sid :: ReaderT SqlBackend (WriterT (Set QueuedJobId) (WriterT All (HandlerFor UniWorX))) Sheet
          (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
          forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText
          lift . lift . tell . All $ null unknown
          now <- liftIO getCurrentTime
          let
            sps' :: [[SheetPseudonym]]
            duplicate :: Set Pseudonym
            ( sps'
              , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate
              ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do
                    known <- State.gets $ Map.member sheetPseudonymPseudonym
                    State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1)
                    return $ bool (p :) id known ps
            submissionPrototype = Submission
              { submissionSheet = sid
              , submissionRatingPoints = Nothing
              , submissionRatingComment = Nothing
              , submissionRatingBy = Just uid
              , submissionRatingAssigned = Just now
              , submissionRatingTime = Nothing
              }
          unless (null duplicate) $
            addMessageModal Warning [whamlet|_{MsgSheetDuplicatePseudonym}|] $ Right $(widgetFile "messages/submissionCreateDuplicates")
          existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
            E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
            E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
                 E.&&. submission E.^. SubmissionSheet E.==. E.val sid
            return submissionUser
          unless (null existingSubUsers) . mapReaderT lift $ do
            (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: _ CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
            let trigger = [whamlet|_{MsgSheetCreateExisting}|]
                content = Right $(widgetFile "messages/submissionCreateExisting")
            addMessageModal Warning trigger content
          let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
          forM_ sps'' $ \spGroup
            -> let
                 sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup
                in case sheetGrouping of
            Arbitrary maxSize -> do
              subId <- insert submissionPrototype
              void . insert $ SubmissionEdit (Just uid) now subId
              audit $ TransactionSubmissionEdit subId sid
              insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
                { submissionUserUser = sheetPseudonymUser
                , submissionUserSubmission = subId
                }
              forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do
                hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId
                audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser
              when (genericLength spGroup > maxSize) $
                addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc
            RegisteredGroups -> do
              let spGroup' = Map.fromList $ map (sheetPseudonymUser &&& id) spGroup
              groups <- E.select . E.from $ \submissionGroup -> do
                E.where_ . E.exists . E.from $ \submissionGroupUser ->
                  E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup)
                return $ submissionGroup E.^. SubmissionGroupId
              groupUsers <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \submissionGroupUser -> do
                E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup `E.in_` E.valList (map E.unValue groups)
                return $ submissionGroupUser E.^. SubmissionGroupUserUser
              if
                | [_] <- groups
                , Map.keysSet spGroup' `Set.isSubsetOf` groupUsers
                  -> do
                    subId <- insert submissionPrototype
                    void . insert $ SubmissionEdit (Just uid) now subId
                    audit $ TransactionSubmissionEdit subId sid
                    insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser
                      { submissionUserUser = sheetUser
                      , submissionUserSubmission = subId
                      }
                    forM_ groupUsers $ \subUid -> do
                      hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid subId
                      audit $ TransactionSubmissionUserEdit subId subUid
                    when (null groups) $
                      addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
                | length groups < 2
                  -> do
                    forM_ (Set.toList (Map.keysSet spGroup' `Set.difference` groupUsers)) $ \((spGroup' !) -> SheetPseudonym{sheetPseudonymPseudonym}) -> do
                      addMessageI Error $ MsgSheetNoRegisteredGroup (review _PseudonymText sheetPseudonymPseudonym)
                      lift . lift . tell $ All False
                | otherwise ->
                    addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
            NoGroups -> do
              subId <- insert submissionPrototype
              void . insert $ SubmissionEdit (Just uid) now subId
              audit $ TransactionSubmissionEdit subId sid
              insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
                { submissionUserUser = sheetPseudonymUser
                , submissionUserSubmission = subId
                }
              forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do
                hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId
                audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser
              when (length spGroup > 1) $
                addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
      when allDone $
        redirect CorrectionsGradeR

  let pseudonymForm = wrapForm pseudonymWidget def
        { formAction   = Just $ SomeRoute CorrectionsCreateR
        , formEncoding = pseudonymEncoding
        }

  siteLayoutMsg MsgCorrCreate $ do
    setTitleI MsgCorrCreate
    $(widgetFile "corrections-create")
  where
    partitionEithers' :: [[Either a b]] -> ([[b]], [a])
    partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers)

    textToList :: Textarea -> ([[Pseudonym]], Map (Text, Text) [Pseudonym])
    textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . map Text.strip . Text.lines . unTextarea -> ws)
      = runWriter . fmap (mapMaybe sequence) $ mapM (\ws' -> mapM (toPseudonym ws') ws') ws
      where
        toPseudonym w' w
          | Just res <- w ^? _PseudonymText = return $ Just res
          | otherwise = Nothing <$ tell (Map.singleton (Text.intercalate ", " w', w) $ w ^.. pseudonymFragments . _PseudonymWords)
