{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}


module Handler.Utils.Submission
  ( SubmissionSinkException(..)
  , sinkSubmission
  ) where

import Import -- hiding ()

import Control.Lens
import Control.Lens.Extras (is)
import Utils.Lens

import Control.Monad.State hiding (forM_)

import Data.Maybe

import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map


import Data.Monoid (Monoid, Any(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault)

import Handler.Utils.Rating

import qualified Database.Esqueleto as E

import qualified Data.Conduit.List as Conduit


assignSubmissions :: SheetId -> YesodDB UniWorX ()
assignSubmissions sid = do
    correctors <- selectList [SheetCorrectorSheet ==. sid] []
    let (corrsGroup, normalize -> corrsProp) = partition (is _ByTutorial . sheetCorrectorLoad . entityVal) correctors
    subs <- E.select . E.from $ \(submission `E.LeftOuterJoin` user) -> do
        let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do
              -- Uncomment next line for equal chance between tutors, irrespective of the number of students per tutor per submission group
              -- E.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do
                E.on (tutorial       E.^. TutorialId         E.==. tutorialUser E.^. TutorialUserTutorial)
                E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser)
                E.where_ (tutorial   E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsGroup))
                return $ tutorial E.^. TutorialTutor
        E.on $ user E.?. UserId `E.in_` E.justList tutors
        E.where_ $  submission E.^. SubmissionSheet E.==. E.val sid
        E.orderBy [E.rand] -- randomize for fair tutor distribution
        return (submission E.^. SubmissionId, user E.?. UserId) -- , listToMaybe tutors)
    let subTutor :: Map SubmissionId (Maybe UserId)
        subTutor = Map.fromListWith (<|>) $ map (bimap E.unValue E.unValue) subs
    -- TODO: Continue here --
    return ()
  where
    _Load :: Traversal' (Entity SheetCorrector) Rational
    _Load = _entityVal . _sheetCorrectorLoad . _ByProportion

    normalize :: [Entity SheetCorrector] -> [Entity SheetCorrector]
    normalize corrsProp = corrsProp & each . _Load //~ sumOf (each . _Load) corrsProp



data SubmissionSinkState = SubmissionSinkState
  { sinkSeenRating :: Any
  , sinkSubmissionTouched :: Any
  , sinkFilenames :: Set FilePath
  } deriving (Show, Eq, Generic, Typeable)

instance Monoid SubmissionSinkState where
  mempty = memptydefault
  mappend = mappenddefault

data SubmissionSinkException = DuplicateFileTitle FilePath
                             | DuplicateRating
                             | RatingWithoutUpdate
                             | ForeignRating
  deriving (Typeable, Show)

instance Exception SubmissionSinkException

sinkSubmission :: SheetId
               -> UserId
               -> Maybe (SubmissionId, Bool {-^ Is this a correction -})
               -> Sink SubmissionContent (YesodDB UniWorX) SubmissionId
-- ^ Replace the currently saved files for the given submission (either
--   corrected files or original ones, depending on arguments) with the supplied
--   'SubmissionContent'.
--
-- Files that don't occur in the 'SubmissionContent' but are in the database
-- are deleted (or marked as deleted in the case of this being a correction).
--
-- A 'Submission' is created if no 'SubmissionId' is supplied
sinkSubmission sheetId userId mExists = do
  now <- liftIO getCurrentTime
  let
    submissionSheet       = sheetId
    submissionRatingPoints  = Nothing
    submissionRatingComment = Nothing
    submissionRatingBy      = Nothing
    submissionRatingTime    = Nothing

  (sId, isUpdate) <- lift $ maybe ((, False) <$> (insert Submission{..} >>= (\sid -> sid <$ insert (SubmissionEdit userId now sid)))) return mExists


  sId <$ sinkSubmission' sId isUpdate
  where
    tell = modify . mappend

    sinkSubmission' :: SubmissionId
                   -> Bool -- ^ Is this a correction
                   -> Sink SubmissionContent (YesodDB UniWorX) ()
    sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
      Left file@(File{..}) -> do
        $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
        
        alreadySeen <- gets (Set.member fileTitle . sinkFilenames)
        when alreadySeen . throwM $ DuplicateFileTitle fileTitle
        tell $ mempty{ sinkFilenames = Set.singleton fileTitle  }

        otherVersions <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do
          E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
          E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
          -- E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
          E.where_ $ f E.^. FileTitle E.==. E.val fileTitle -- 'Zip.hs' normalises filenames already, so this should work
          return (f, sf)

        let collidingFiles = [ t | t@(_, Entity _ sf) <- otherVersions
                                 , submissionFileIsUpdate sf == isUpdate
                                 ]
            underlyingFiles = [ t | t@(_, Entity _ sf) <- otherVersions
                                  , submissionFileIsUpdate sf == False
                                  ]
            anyChanges
              | not (null collidingFiles)  = any (/~ file) [ f | (Entity _ f, _) <- collidingFiles ]
              | otherwise                  = True
            matchesUnderlying
              | not (null underlyingFiles) = all (~~ file) [ f | (Entity _ f, Entity _ _sf) <- underlyingFiles ]
              | otherwise                  = False
            undoneDeletion = any submissionFileIsDeletion [ sf | (_, Entity _ sf) <- collidingFiles ]
  
        when anyChanges $ do
          touchSubmission
          when (not $ null collidingFiles) $
            lift $ deleteCascadeWhere [ FileId <-. [ fId | (Entity fId _, _) <- collidingFiles ] ]
          lift $ case () of
            _ | matchesUnderlying
              , isUpdate
                -> return ()
            _   -> do
              fileId <- insert file
              insert_ $ SubmissionFile
                { submissionFileSubmission = submissionId
                , submissionFileFile = fileId
                , submissionFileIsUpdate = isUpdate
                , submissionFileIsDeletion = False
                }
        when undoneDeletion $ do
          touchSubmission
          lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ]
  
      Right (submissionId', Rating'{..}) -> do
        $logDebugS "sinkSubmission" $ tshow submissionId'

        unless (submissionId' == submissionId) $ throwM ForeignRating
        
        alreadySeen <- gets $ getAny . sinkSeenRating
        when alreadySeen $ throwM DuplicateRating
        tell $ mempty{ sinkSeenRating = Any True }

        unless isUpdate $ throwM RatingWithoutUpdate

        Submission{..} <- lift $ getJust submissionId

        let anyChanges = or $ 
              [ submissionRatingPoints /= ratingPoints
              , submissionRatingComment /= ratingComment
              ]
        -- 'ratingTime' is ignored for consistency with 'File's:
        -- 
        -- 'fileModified' is simply stored and never inspected while
        -- 'submissionChanged' is always set to @now@.

        when anyChanges $ do
          touchSubmission
          lift $ update submissionId
            [ SubmissionRatingPoints =. ratingPoints
            , SubmissionRatingComment =. ratingComment
            ]
      where
        a /~ b = not $ a ~~ b

        (~~) :: File -> File -> Bool
        (~~) a b
          | isUpdate  = fileTitle a == fileTitle b && fileContent a == fileContent b
          | otherwise = a == b
        -- The Eq Instance for File compares modification time exactly even
        -- though zip archives have very limited accuracy and range regarding
        -- timestamps.
        -- We thus expect to replace files a little more often than is actually
        -- necessary.
        -- This was done on the premise that changes in file modification time
        -- break file identity under upload and re-download.
        --
        -- The check whether the new version matches the underlying file is
        -- more lenient, considering only filename and -content.

        touchSubmission :: StateT SubmissionSinkState (YesodDB UniWorX) ()
        touchSubmission = do
          alreadyTouched <- gets $ getAny . sinkSubmissionTouched
          when (not alreadyTouched) $ do
            now <- liftIO getCurrentTime
            lift $ case isUpdate of
              False -> insert_ $ SubmissionEdit userId now submissionId
              True  -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
            tell $ mempty{ sinkSubmissionTouched = Any True }

        finalize :: SubmissionSinkState -> YesodDB UniWorX ()
        finalize SubmissionSinkState{..} = do
          missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
            E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
            E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
            when (not isUpdate) $
              E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
            E.where_ $ f E.^. FileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
            E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]

            return (f, sf)

          case isUpdate of
            False -> deleteCascadeWhere [ FileId <-. [ fileId | (Entity fileId _, _) <- missingFiles ] ]
            True  -> forM_ missingFiles $ \(Entity fileId File{..}, Entity sfId SubmissionFile{..}) -> do
              shadowing <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
                E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
                E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
                E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val (not isUpdate)
                E.where_ $ f E.^. FileTitle E.==. E.val fileTitle
                return $ f E.^. FileId

              case (shadowing, submissionFileIsUpdate) of
                ([], _) -> deleteCascade fileId
                (E.Value f:_, False) -> do
                  insert_ $ SubmissionFile
                    { submissionFileSubmission = submissionId
                    , submissionFileFile = f
                    , submissionFileIsUpdate = True
                    , submissionFileIsDeletion = True
                    }
                (E.Value f:_, True) -> do
                  update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ]
                  deleteCascade fileId

          when (isUpdate && not (getAny sinkSeenRating)) $
            update submissionId
              [ SubmissionRatingTime =. Nothing
              , SubmissionRatingPoints =. Nothing
              , SubmissionRatingBy =. Nothing
              , SubmissionRatingComment =. Nothing
              ]