{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiWayIf, LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Handler.Corrections where

import Import
-- import System.FilePath (takeFileName)

import Handler.Utils
import Handler.Utils.Submission
-- import Handler.Utils.Zip

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

import qualified Data.Text as Text

-- import Data.Time
-- import qualified Data.Text as T
-- import Data.Function ((&))
--
import Colonnade hiding (fromMaybe, singleton, bool)
-- import Yesod.Colonnade
--
-- import qualified Data.UUID.Cryptographic as UUID
-- import qualified Data.Conduit.List as C

import qualified Database.Esqueleto as E
-- import qualified Database.Esqueleto.Internal.Sql as E

import Control.Lens
-- import Control.Monad.Writer (MonadWriter(..), execWriterT)

-- import Network.Mime

import Web.PathPieces

import Text.Hamlet (ihamletFile)
import Text.Blaze.Html (preEscapedToHtml)

import Database.Persist.Sql (updateWhereCount)

import Data.List (genericLength)



type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) =>
            (expr (Entity Course), expr (Entity Sheet), expr (Entity Submission))
            -> expr (E.Value Bool)

ratedBy :: Key User -> CorrectionsWhere
ratedBy uid (_course,_sheet,submission) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)

courseIs :: Key Course -> CorrectionsWhere
courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid

sheetIs :: Key Sheet -> CorrectionsWhere
sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid


type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (E.Value Text, E.Value Text, E.Value (Key Term), E.Value (Key School)), Maybe (Entity User))

colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgTerm)
        $ \DBRow{ dbrOutput=(_, _, course, _) } ->
          -- cell [whamlet| _{untermKey $ course ^. _3}|]   -- lange, internationale Semester
          textCell $ termToText $ unTermKey $ E.unValue $ course ^. _3 -- kurze Semsterkürzel

colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse)
        $ \DBRow{ dbrOutput=(_, _, course, _) } -> cell $
          let tid = E.unValue $ course ^. _3
              csh = E.unValue $ course ^. _2
          in [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]

colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
        $ \DBRow{ dbrOutput=(_, sheet, course, _) } -> cell $
          let tid = E.unValue $ course ^. _3
              csh = E.unValue $ course ^. _2
              shn = sheetName $ entityVal sheet
          in [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|]
          -- textCell $ sheetName $ entityVal sheet

colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
  DBRow{ dbrOutput = (_, _, _, Nothing) } -> cell mempty
  DBRow{ dbrOutput = (_, _, _, Just corr) } -> textCell . display . userDisplayName $ entityVal corr

colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
        $ \DBRow{ dbrOutput=(submission, sheet, course, _) } -> cell $ do
          let tid = E.unValue $ course ^. _3
              csh = E.unValue $ course ^. _2
              shn = sheetName $ entityVal sheet
          cid <- encrypt (entityKey submission :: SubmissionId)
          [whamlet|<a href=@{CSubmissionR tid csh shn cid SubShowR}>#{display cid}|]

colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encrypt subId

type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
            
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
                     => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
makeCorrectionsTable whereClause colChoices psValidator = do
  let tableData :: CorrectionTableExpr -> E.SqlQuery _
      tableData ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
        E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
        E.on $ sheet  E.^. SheetId  E.==. submission E.^. SubmissionSheet
        E.on $ course E.^. CourseId E.==. sheet      E.^. SheetCourse
        E.where_ $ whereClause (course,sheet,submission)
        let crse =  ( course E.^. CourseName      :: E.SqlExpr (E.Value Text)
                    , course E.^. CourseShorthand
                    , course E.^. CourseTerm
                    , course E.^. CourseSchool    :: E.SqlExpr (E.Value SchoolId)
                    )
        return (submission, sheet, crse, corrector)
  dbTable psValidator $ DBTable
    { dbtSQLQuery  = tableData
    , dbtColonnade = colChoices
    , dbtProj      = return 
    , dbtSorting   = [ ( "term"
                       , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
                       )
                     , ( "course"
                       , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
                       )
                     , ( "sheet"
                       , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName
                       )
                     , ( "corrector"
                       , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserDisplayName
                       )
                     ]
    , dbtFilter    = [ ( "term"
                       , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if
                           | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
                           | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
                       )
                     , ( "course"
                       , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if
                           | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool)
                           | otherwise     -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs)
                       )
                     , ( "sheet"
                       , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if
                           | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool)
                           | otherwise     -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns)
                       )
                     , ( "corrector"
                       , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if
                           | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool)
                           | otherwise       -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails)
                                          E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
                       )
                     ]
    , dbtStyle     = def
    , dbtIdent     = "corrections" :: Text
    }

data ActionCorrections = CorrDownload
                       | CorrSetCorrector
                       | CorrAutoSetCorrector
  deriving (Eq, Ord, Read, Show, Enum, Bounded)
instance PathPiece ActionCorrections where
  fromPathPiece = readFromPathPiece
  toPathPiece = showToPathPiece

instance RenderMessage UniWorX ActionCorrections where
  renderMessage m ls CorrDownload = renderMessage m ls MsgCorrDownload
  renderMessage m ls CorrSetCorrector = renderMessage m ls MsgCorrSetCorrector
  renderMessage m ls CorrAutoSetCorrector = renderMessage m ls MsgCorrAutoSetCorrector

data ActionCorrectionsData = CorrDownloadData
                           | CorrSetCorrectorData (Maybe UserId)
                           | CorrAutoSetCorrectorData SheetId

correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) -> Handler TypedContent
correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
  tableForm <- makeCorrectionsTable whereClause displayColumns psValidator
  ((actionRes, table), tableEncoding) <- runFormPost . identForm FIDcorrectorTable $ \csrf -> do
    ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
    (actionRes, action) <- multiAction actions
    return ((,) <$> actionRes <*> selectionRes, table <> action)

  Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
  case actionRes of
    FormFailure errs -> mapM_ (addMessage "danger" . toHtml) errs
    FormMissing      -> return ()
    FormSuccess (CorrDownloadData, subs) -> do
      ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
      addHeader "Content-Disposition" "attachment; filename=\"corrections.zip\""
      sendResponse =<< submissionMultiArchive ids
    FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do
      subs <- mapM decrypt $ Set.toList subs'
      runDB $ do
        alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
        when (not $ null alreadyAssigned) $ do
          mr <- (toHtml . ) <$> getMessageRender
          alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) 
          addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
        let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
        when (not $ null unassigned) $ do
          num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] [SubmissionRatingBy =. Just uid]
          addMessageI "success" $ MsgUpdatedAssignedCorrectorSingle num
      redirect currentRoute
    FormSuccess (CorrSetCorrectorData Nothing, subs') -> do
      subs <- mapM decrypt $ Set.toList subs'
      runDB $ do
        num <- updateWhereCount [SubmissionId <-. subs] [ SubmissionRatingPoints =. Nothing
                                                        , SubmissionRatingComment =. Nothing
                                                        , SubmissionRatingBy =. Nothing
                                                        , SubmissionRatingTime =. Nothing
                                                        ]
        addMessageI "success" $ MsgRemovedCorrections num
      redirect currentRoute
    FormSuccess (CorrAutoSetCorrectorData shid, subs') -> do
      subs <- mapM decrypt $ Set.toList subs'
      runDB $ do
        alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
        when (not $ null alreadyAssigned) $ do
          mr <- (toHtml . ) <$> getMessageRender
          alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) 
          addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
        let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
        when (not $ null unassigned) $ do
          (assigned, unassigned) <- assignSubmissions shid (Just unassigned)
          when (not $ null assigned) $
            addMessageI "success" $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
          when (not $ null unassigned) $ do
            mr <- (toHtml . ) <$> getMessageRender
            unassigned' <- forM (Set.toList unassigned) $ \sid -> (encrypt sid :: DB CryptoFileNameSubmission) 
            addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
      redirect currentRoute

  fmap toTypedContent . defaultLayout $ do
    setTitleI MsgCourseCorrectionsTitle
    $(widgetFile "corrections")


type ActionCorrections' = (ActionCorrections, MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget))
  
downloadAction :: ActionCorrections'
downloadAction = ( CorrDownload
                 , return (pure CorrDownloadData, Nothing)
                 )

assignAction :: Either CourseId SheetId -> ActionCorrections'
assignAction selId = ( CorrSetCorrector
                     , over (mapped._2) Just $ do
                         correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
                           E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
                           E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
                           E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse

                           E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId

                           return user

                         mr <- getMessageRender

                         correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey

                         ($ mempty) . renderAForm FormStandard . wFormToAForm $ do
                            cId <- wreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing
                            fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
                     )

autoAssignAction :: SheetId -> ActionCorrections'
autoAssignAction shid = ( CorrAutoSetCorrector
                        , return (pure $ CorrAutoSetCorrectorData shid, Nothing)
                        )

getCorrectionsR, postCorrectionsR :: Handler TypedContent
getCorrectionsR = postCorrectionsR
postCorrectionsR = do
  uid <- requireAuthId
  let whereClause = ratedBy uid
      colonnade = mconcat
        [ colSelect
        , dbRow
        , colTerm
        , colCourse
        , colSheet
        , colSubmissionLink
        ] -- Continue here
      psValidator = def
        & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
        & restrictSorting (\name _ -> name /= "corrector")
  correctionsR whereClause colonnade psValidator $ Map.fromList
    [ downloadAction
    ]

getCCorrectionsR, postCCorrectionsR ::  TermId -> Text -> Handler TypedContent
getCCorrectionsR = postCCorrectionsR
postCCorrectionsR tid csh = do
  Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh
  let whereClause = courseIs cid
      colonnade = mconcat
        [ colSelect
        , dbRow
        , colSheet
        , colCorrector
        , colSubmissionLink
        ] -- Continue here
      psValidator = def
  correctionsR whereClause colonnade psValidator $ Map.fromList
    [ downloadAction
    , assignAction (Left cid)
    ]

getSSubsR, postSSubsR :: TermId -> Text -> Text -> Handler TypedContent
getSSubsR = postSSubsR
postSSubsR tid csh shn = do
  shid <- runDB $ fetchSheetId tid csh shn
  let whereClause = sheetIs shid
      colonnade = mconcat
        [ colSelect
        , dbRow
        , colCorrector
        , colSubmissionLink
        ]
      psValidator = def
  correctionsR whereClause colonnade psValidator $ Map.fromList
    [ downloadAction
    , assignAction (Right shid)
    , autoAssignAction shid
    ]

correctionData tid csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
  E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
  E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
  E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId

  E.where_ $ course E.^. CourseTerm E.==. E.val tid
       E.&&. course E.^. CourseShorthand E.==. E.val csh
       E.&&. sheet  E.^. SheetName E.==. E.val shn
       E.&&. submission E.^. SubmissionId E.==. E.val sub

  return (course, sheet, submission, corrector)

getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler Html
getCorrectionR tid csh shn cid = do
  mayPost <- isAuthorized (CSubmissionR tid csh shn cid CorrectionR) True
  bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid csh shn cid
postCorrectionR tid csh shn cid = do
  sub <- decrypt cid

  results <- runDB $ correctionData tid csh shn sub

  case results of
    [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do
      let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))

      ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,)
        <$> aopt pointsField (fslI MsgRatingPoints) (Just $ submissionRatingPoints)
        <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
        <* submitButton

      ((uploadResult, uploadForm), uploadEncoding) <- runFormPost . identForm FIDcorrectionUpload . renderAForm FormStandard $
            areq (zipFileField True) (fslI MsgRatingFiles) Nothing
        <*  submitButton

      case corrResult of
        FormMissing -> return ()
        FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
        FormSuccess (ratingPoints, ratingComment) -> do
          runDB $ do
            uid <- liftHandlerT requireAuthId
            now <- liftIO getCurrentTime

            let rated = isJust $ void ratingPoints <|> void ratingComment
          
            update sub [ SubmissionRatingBy =. (uid <$ guard rated)
                       , SubmissionRatingTime =. (now <$ guard rated)
                       , SubmissionRatingPoints =. ratingPoints
                       , SubmissionRatingComment =. ratingComment
                       ]

            addMessageI "success" $ bool MsgRatingDeleted MsgRatingUpdated rated
          redirect $ CSubmissionR tid csh shn cid CorrectionR

      case uploadResult of
        FormMissing -> return ()
        FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
        FormSuccess fileSource -> do
          uid <- requireAuthId
          
          runDB . runConduit $ transPipe lift fileSource .| extractRatings .| sinkSubmission uid (Right sub) True

          addMessageI "success" MsgRatingFilesUpdated
          redirect $ CSubmissionR tid csh shn cid CorrectionR

      defaultLayout $ do
        let userCorrection = $(widgetFile "correction-user")
        $(widgetFile "correction")
    _ -> notFound
getCorrectionUserR tid csh shn cid = do
  sub <- decrypt cid
  
  results <- runDB $ correctionData tid csh shn sub

  case results of
    [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do
      let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
      
      defaultLayout $ do
        $(widgetFile "correction-user")
    _ -> notFound

  
getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
getCorrectionsUploadR = postCorrectionsUploadR
postCorrectionsUploadR = do
  ((uploadRes, upload), uploadEncoding) <- runFormPost . identForm FIDcorrectionsUpload . renderAForm FormStandard $
       areq (zipFileField True) (fslI MsgCorrUploadField) Nothing
    <* submitButton

  case uploadRes of
    FormMissing -> return ()
    FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
    FormSuccess files -> do
      uid <- requireAuthId
      subs <- runDB . runConduit $ transPipe lift files .| extractRatings .| sinkMultiSubmission uid True
      subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
      mr <- (toHtml .) <$> getMessageRender
      addMessage "success" =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)

  defaultLayout $ do
    $(widgetFile "corrections-upload")