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

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

module Handler.Utils.Zip.Rating
  ( Rating(..), Rating'(..)
  , getRating
  , formatRating
  , ratingFile
  , RatingException(..)
  , UnicodeException(..)
  , isRatingFile
  , parseRating
  , SubmissionContent
  , extractRatings
  , SubmissionSinkException(..)
  , sinkSubmission
  ) where

import Import hiding ((</>))


import Text.PrettyPrint.Leijen.Text hiding ((<$>))

import Control.Monad.Trans.Maybe
import Control.Monad.State hiding (forM_)

import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Text.Encoding.Error (UnicodeException(..))

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

import Data.Monoid (Monoid, Any(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
  
import qualified Data.Text.Lazy.Encoding as Lazy.Text

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

import qualified Data.ByteString.Lazy as Lazy (ByteString)
import qualified Data.ByteString.Lazy as Lazy.ByteString

import Text.Read (readEither)

import GHC.Generics (Generic)
import Data.Typeable (Typeable)

import CryptoID.Base32 as Base32

import System.FilePath

import qualified Database.Esqueleto as E

import qualified Data.Conduit.List as Conduit


instance HasResolution prec => Pretty (Fixed prec) where
  pretty = pretty . show

instance Pretty x => Pretty (CI x) where
  pretty = pretty . CI.original


data Rating = Rating
  { ratingCourseName :: Text
  , ratingSheetName :: Text
  , ratingValues :: Rating'
  } deriving (Read, Show, Eq, Generic, Typeable)

data Rating' = Rating'
  { ratingPoints :: Maybe Points
  , ratingComment :: Maybe Text
  , ratingTime :: Maybe UTCTime
  } deriving (Read, Show, Eq, Generic, Typeable)

data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode
                     | RatingMissingSeparator -- ^ Could not split rating header from comments
                     | RatingMultiple -- ^ Encountered multiple point values in rating
                     | RatingInvalid String -- ^ Failed to parse rating point value
                     | RatingFileIsDirectory -- ^ We do not expect this to, it's included for totality
  deriving (Show, Eq, Generic, Typeable)

instance Exception RatingException


getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)
getRating submissionId = runMaybeT $ do
  let query = E.select . E.from $ \(submission `E.InnerJoin` sheet `E.InnerJoin` course) -> do
        E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
        E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheetId

        E.where_ $ submission E.^. SubmissionId E.==. E.val submissionId

        -- Yes, we can only pass a tuple through 'E.select'
        return ( course E.^. CourseName
               , sheet E.^. SheetName
               , submission E.^. SubmissionRatingPoints
               , submission E.^. SubmissionRatingComment
               , submission E.^. SubmissionRatingTime
               )

  [ ( E.unValue -> ratingCourseName
    , E.unValue -> ratingSheetName
    , E.unValue -> ratingPoints
    , E.unValue -> ratingComment
    , E.unValue -> ratingTime
    ) ] <- lift query
  
  return Rating{ ratingValues = Rating'{..}, .. }

formatRating :: CryptoFileNameSubmission -> Rating -> Lazy.ByteString
formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let
  doc = renderPretty 1 45 $ foldr (<$$>) mempty
    [ "= Bitte nur Bewertung und Kommentare ändern ="
    , "============================================="
    , "========== UniWorx Bewertungsdatei =========="
    , "======= diese Datei ist UTF8 encodiert ======"
    , "Informationen zum Übungsblatt:"
    , indent 2 $ foldr (<$$>) mempty
      [ "Veranstaltung:" <+> pretty ratingCourseName
      , "Blatt:" <+> pretty ratingSheetName
      ]
    , "Abgabe-Id:" <+> pretty (ciphertext cID)
    , "============================================="
    , "Bewertung:" <+> pretty ratingPoints
    , "=========== Beginn der Kommentare ==========="
    , pretty ratingComment
    ]
  in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc

ratingFile :: CryptoFileNameSubmission -> Rating -> Maybe File
ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do
  fileModified <- ratingTime
  let
    fileTitle = "bewertung_" <> (Text.unpack . CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)) <.> "txt"
    fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating
  return File{..}

parseRating :: MonadThrow m => File -> m Rating'
parseRating File{ fileContent = Just input, .. } = do
  inputText <- either (throw . RatingNotUnicode) return $ Text.decodeUtf8' input
  let
    (headerLines, commentLines) = break (sep `Text.isInfixOf`) $ Text.lines inputText
    ratingLines = filter (rating `Text.isInfixOf`) headerLines
    sep = "Beginn der Kommentare"
    rating = "Bewertung:"
  comment' <- case commentLines of
    (_:commentLines') -> return . Text.strip $ Text.unlines commentLines'
    _ -> throw RatingMissingSeparator
  let
    ratingComment
      | Text.null comment' = Nothing
      | otherwise = Just comment'
  ratingLine' <- case ratingLines of
    [l] -> return l
    _ -> throw RatingMultiple
  let
    (_, ratingLine) = Text.breakOnEnd rating ratingLine'
    ratingStr = Text.unpack $ Text.strip ratingLine
  ratingPoints <- case () of
    _ | null ratingStr -> return Nothing
      | otherwise -> either (throw . RatingInvalid) return $ Just <$> readEither ratingStr
  return Rating'{ ratingTime = Just fileModified, .. }
parseRating _ = throwM RatingFileIsDirectory


type SubmissionContent = Either File (SubmissionId, Rating')

extractRatings :: ( MonadHandler m
                  , HandlerSite m ~ UniWorX
                  , MonadCatch m
                  ) => Conduit File m SubmissionContent
extractRatings = Conduit.mapM $ \f@File{..} -> do
  msId <- isRatingFile fileTitle
  case () of
    _ | Just sId <- msId
      , isJust fileContent
        -> Right . (sId, ) <$> parseRating f
      | otherwise -> return $ Left f

isRatingFile :: ( MonadHandler m
                , HandlerSite m ~ UniWorX
                , MonadCatch m
                ) => FilePath -> m (Maybe SubmissionId)
isRatingFile fName
  | Just cID <- isRatingFile' fName = do
      cIDKey <- getsYesod appCryptoIDKey
      (Just <$> Base32.decrypt cIDKey cID) `catch` decryptErrors
  | otherwise = return Nothing
  where

    decryptErrors (CiphertextConversionFailed _) = return Nothing
    decryptErrors InvalidNamespaceDetected       = return Nothing
    decryptErrors DeserializationError           = return Nothing
    decryptErrors err                            = throwM err

isRatingFile' :: FilePath -> Maybe CryptoFileNameSubmission
isRatingFile' (normalise -> fName)
  | (bName, ".txt") <- splitExtension fName
  , Just (CI.mk . Text.pack -> ciphertext) <- stripPrefix "bewertung_" bName
  = Just CryptoID{..}
  | otherwise
  = Nothing


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
sinkSubmission sheetId userId mExists = do
  now <- liftIO getCurrentTime
  let
    submissionSheetId       = sheetId
    submissionRatingPoints  = Nothing
    submissionRatingComment = Nothing
    submissionRatingBy      = Nothing
    submissionRatingTime    = Nothing
    submissionCreated       = now
    submissionChanged       = now
    submissionCreatedBy     = userId
    submissionChangedBy     = userId

  (sId, isUpdate) <- lift $ maybe ((, False) <$> insert Submission{..}) 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
        alreadySeen <- gets (Set.member fileTitle . sinkFilenames)
        when alreadySeen . throwM $ DuplicateFileTitle fileTitle
        tell $ mempty{ sinkFilenames = Set.singleton fileTitle  }

        collidingFiles <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do
          E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId
          E.where_ $ sf E.^. SubmissionFileSubmissionId 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 anyChanges
              | not (null collidingFiles) = any (/= file) [ f | (Entity _ f, _) <- collidingFiles ]
              | otherwise                 = True
            undoneDeletion = any submissionFileIsDeletion [ sf | (_, Entity _ sf) <- collidingFiles ]
        -- 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.
        --
        -- We could check whether the new version of the file matches the
        -- version of the file for which 'isUpdate' is different from this
        -- one's, and, if so, simply delete the version for which 'isUpdate' is
        -- 'True', reverting the correction.
        --
        -- This idea was discarded since modification times make this difficult
        -- to implement properly – should we equate file versions that differ in
        -- modification time?
  
        when anyChanges $ do
          touchSubmission
          when (not $ null collidingFiles) $
            lift $ deleteCascadeWhere [ FileId <-. [ fId | (Entity fId _, _) <- collidingFiles ] ]
          fileId <- lift $ insert file
          lift . insert_ $ SubmissionFile
            { submissionFileSubmissionId = submissionId
            , submissionFileFileId = fileId
            , submissionFileIsUpdate = isUpdate
            , submissionFileIsDeletion = False
            }
        when undoneDeletion $ do
          touchSubmission
          lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ]
  
      Right (submissionId', Rating'{..}) -> do
        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
        touchSubmission :: StateT SubmissionSinkState (YesodDB UniWorX) ()
        touchSubmission = do
          alreadyTouched <- gets $ getAny . sinkSubmissionTouched
          when (not alreadyTouched) $ do
            now <- liftIO getCurrentTime
            lift . update submissionId $ case isUpdate of
              False -> [ SubmissionChangedBy =. userId, SubmissionChanged =. now ]
              True  -> [ 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.^. SubmissionFileFileId E.==. f E.^. FileId
            E.where_ $ sf E.^. SubmissionFileSubmissionId 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.^. SubmissionFileFileId E.==. f E.^. FileId
                E.where_ $ sf E.^. SubmissionFileSubmissionId 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
                    { submissionFileSubmissionId = submissionId
                    , submissionFileFileId = f
                    , submissionFileIsUpdate = True
                    , submissionFileIsDeletion = True
                    }
                (E.Value f:_, True) -> do
                  update sfId [ SubmissionFileFileId =. f, SubmissionFileIsDeletion =. True ]
                  deleteCascade fileId

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