{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Handler.ExamOffice.Exam
  ( getEGradesR, postEGradesR
  , examCloseWidget
  ) where

import Import
import Handler.Utils
import Handler.Utils.Exam
import Handler.Utils.Csv
import qualified Handler.Utils.ExamOffice.Exam as Exam

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E

import qualified Data.Csv as Csv

import qualified Data.Set as Set
import qualified Data.Map as Map

import qualified Data.Conduit.List as C
import qualified Colonnade

import Handler.Utils.StudyFeatures


data ButtonCloseExam = BtnCloseExam
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonCloseExam
instance Finite ButtonCloseExam

nullaryPathPiece ''ButtonCloseExam $ camelToPathPiece' 1

embedRenderMessage ''UniWorX ''ButtonCloseExam id
instance Button UniWorX ButtonCloseExam where
  btnClasses BtnCloseExam = [BCIsButton]


examCloseWidget :: SomeRoute UniWorX -> ExamId -> Handler Widget
examCloseWidget dest eId = do
  (Exam{..}, School{..})  <- runDB $ do
    exam@Exam{..} <- get404 eId
    Course{..} <- get404 examCourse
    school <- get404 courseSchool
    return (exam, school)

  let closeTime = case (examClosed, examFinished) of
        (mClose, Just finish)
          | isn't _ExamCloseSeparate schoolExamCloseMode -> Just $ maybe id min mClose finish
        (Just close, _)
          | is _ExamCloseSeparate schoolExamCloseMode -> Just close
        _other -> Nothing

  examClosedStr <- for closeTime $ formatTime SelFormatDateTime

  if | is _ExamCloseOnFinished' schoolExamCloseMode
       -> return $(widgetFile "widgets/exam-close-on-finished")
     | otherwise -> do
         ((closeRes, closeView'), closeEnc) <- runFormPost $ identifyForm BtnCloseExam buttonForm

         formResult closeRes $ \case
           BtnCloseExam -> do
             now <- liftIO getCurrentTime

             unless (is _Nothing examClosed) $
               invalidArgs ["Exam is already closed"]

             runDB $ update eId [ ExamClosed =. Just now ]
             addMessageI Success MsgExamDidClose
             redirect dest

         let closeView = wrapForm closeView' def
               { formSubmit   = FormNoSubmit
               , formAction   = Just dest
               , formEncoding = closeEnc
               }

         return $(widgetFile "widgets/exam-close")


type ExamUserTableExpr = (              E.SqlExpr (Entity ExamResult)
                          `E.InnerJoin` E.SqlExpr (Entity User)
                         )
       `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamRegistration))
       `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence))
       `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant))
type ExamUserTableData = DBRow ( Entity ExamResult
                               , Entity User
                               , Maybe (Entity ExamOccurrence)
                               , Maybe (Entity ExamRegistration)
                               , Bool
                               , [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
                               , UserTableStudyFeatures
                               )

queryExamRegistration :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamRegistration)))
queryExamRegistration = to $(E.sqlLOJproj 4 2)

queryUser :: Getter ExamUserTableExpr (E.SqlExpr (Entity User))
queryUser = to $ $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 4 1)

queryExamOccurrence :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamOccurrence)))
queryExamOccurrence = to $(E.sqlLOJproj 4 3)

queryCourseParticipant :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant)))
queryCourseParticipant = to $(E.sqlLOJproj 4 4)

queryExamResult :: Getter ExamUserTableExpr (E.SqlExpr (Entity ExamResult))
queryExamResult = to $ $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 4 1)

-- resultExamRegistration :: Traversal' ExamUserTableData (Entity ExamRegistration)
-- resultExamRegistration = _dbrOutput . _7 . _Just

queryIsSynced :: E.SqlExpr (E.Value UserId) -> Getter ExamUserTableExpr (E.SqlExpr (E.Value Bool))
queryIsSynced authId = to $ Exam.resultIsSynced authId <$> view queryExamResult

resultUser :: Lens' ExamUserTableData (Entity User)
resultUser = _dbrOutput . _2

resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
resultExamOccurrence = _dbrOutput . _3 . _Just

resultExamResult :: Lens' ExamUserTableData (Entity ExamResult)
resultExamResult = _dbrOutput . _1

resultIsSynced :: Lens' ExamUserTableData Bool
resultIsSynced = _dbrOutput . _5

resultSynchronised :: Traversal' ExamUserTableData (UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)
resultSynchronised = _dbrOutput . _6 . traverse

resultStudyFeatures :: Lens' ExamUserTableData UserTableStudyFeatures
resultStudyFeatures = _dbrOutput . _7

data ExamUserTableCsv = ExamUserTableCsv
  { csvEUserSurname         :: Text
  , csvEUserFirstName       :: Text
  , csvEUserName            :: Text
  , csvEUserMatriculation   :: Maybe Text
  , csvEUserStudyFeatures   :: UserTableStudyFeatures
  , csvEUserOccurrenceStart :: Maybe ZonedTime
  , csvEUserExamResult      :: ExamResultPassedGrade
  }
  deriving (Generic)
makeLenses_ ''ExamUserTableCsv

examUserTableCsvOptions :: Csv.Options
examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }

instance ToNamedRecord ExamUserTableCsv where
  toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions

instance DefaultOrdered ExamUserTableCsv where
  headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions

instance CsvColumnsExplained ExamUserTableCsv where
  csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList
    [ ('csvEUserSurname             , MsgCsvColumnExamUserSurname                   )
    , ('csvEUserFirstName           , MsgCsvColumnExamUserFirstName                 )
    , ('csvEUserName                , MsgCsvColumnExamUserName                      )
    , ('csvEUserMatriculation       , MsgCsvColumnExamUserMatriculation             )
    , ('csvEUserStudyFeatures       , MsgCsvColumnUserStudyFeatures                 )
    , ('csvEUserOccurrenceStart     , MsgCsvColumnExamOfficeExamUserOccurrenceStart )
    , ('csvEUserExamResult          , MsgCsvColumnExamUserResult                    )
    ]

data ExamUserAction = ExamUserMarkSynchronised
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

instance Universe ExamUserAction
instance Finite ExamUserAction
nullaryPathPiece ''ExamUserAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''ExamUserAction id

data ExamUserActionData = ExamUserMarkSynchronisedData

newtype ExamUserCsvExportData = ExamUserCsvExportData
  { csvEUserMarkSynchronised :: Bool
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)


-- | View a list of all users' grades that the current user has access to
getEGradesR, postEGradesR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEGradesR = postEGradesR
postEGradesR tid ssh csh examn = do
  uid <- requireAuthId
  now <- liftIO getCurrentTime
  ((usersResult, examUsersTable), Entity eId _) <- runDB $ do
    exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
    Course{..} <- getJust examCourse

    csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn)
    isLecturer <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR
    userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] []

    let
      participantLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (SomeRoute UniWorX)
      participantLink partId = liftHandler $ do
        cID <- encrypt partId
        return . SomeRoute . CourseR tid ssh csh $ CUserR cID

      participantAnchor :: ExamUserTableData -> DBCell _ _ -> DBCell _ _
      participantAnchor x = cellContents . mapped <>~ partAnchor
        where
          partAnchor :: Widget
          partAnchor = do
            let partId = x ^. resultUser . _entityKey
            cID <- encrypt partId :: WidgetFor UniWorX CryptoUUIDUser
            [whamlet|
              $newline never
              <span ##{toPathPiece cID}>
            |]

      markSynced :: ExamResultId -> DB ()
      markSynced resId
        | null userFunctions =
            insert_ ExamOfficeResultSynced
              { examOfficeResultSyncedOffice = uid
              , examOfficeResultSyncedResult = resId
              , examOfficeResultSyncedTime   = now
              , examOfficeResultSyncedSchool = Nothing
              }
        | otherwise =
            insertMany_ [ ExamOfficeResultSynced
                          { examOfficeResultSyncedOffice = uid
                          , examOfficeResultSyncedResult = resId
                          , examOfficeResultSyncedTime   = now
                          , examOfficeResultSyncedSchool = Just userFunctionSchool
                          }
                        | Entity _ UserFunction{..} <- userFunctions
                        ]


      examUsersDBTable = DBTable{..}
        where
          dbtSQLQuery = runReaderT $ do
            examResult <- view queryExamResult
            user <- view queryUser
            examRegistration <- view queryExamRegistration
            occurrence <- view queryExamOccurrence
            courseParticipant <- view queryCourseParticipant

            isSynced <- view . queryIsSynced $ E.val uid

            lift $ do
              E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
               E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
               E.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
              E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
               E.&&. occurrence E.?. ExamOccurrenceId   E.==. E.joinV (examRegistration E.?. ExamRegistrationOccurrence)
              E.on $ examRegistration E.?. ExamRegistrationUser E.==. E.just (user E.^. UserId)
               E.&&. examRegistration E.?. ExamRegistrationExam E.==. E.just (E.val eid)
              E.on $ examResult E.^. ExamResultUser E.==. user E.^. UserId
               E.&&. examResult E.^. ExamResultExam E.==. E.val eid

              E.where_ $ examResult E.^. ExamResultExam E.==. E.val eid

              unless isLecturer $
                E.where_ $ Exam.examOfficeExamResultAuth (E.val uid) examResult

            return (examResult, user, occurrence, examRegistration, isSynced)
          dbtRowKey = views queryExamResult (E.^. ExamResultId)

          dbtProj :: DBRow _ -> DB ExamUserTableData
          dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
            (,,,,,,)
              <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view (_5 . _Value)
              <*> getSynchronised
              <*> (lift . courseUserStudyFeatures examCourse =<< view (_2 . _entityKey))
            where
              getSynchronised :: ReaderT _ DB [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
              getSynchronised = do
                resId <- view $ _1 . _entityKey
                syncs <- lift . E.select . E.from $ \(examOfficeResultSynced `E.InnerJoin` user) -> do
                  E.on $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. user E.^. UserId
                  E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedResult E.==. E.val resId
                  return ( examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice
                         , ( user E.^. UserDisplayName
                           , user E.^. UserSurname
                           , examOfficeResultSynced E.^. ExamOfficeResultSyncedTime
                           , examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool
                           )
                         )
                let syncs' = Map.fromListWith
                               (\(dn, sn, t, sshs) (_, _, _, sshs') -> (dn, sn, t, Set.union sshs sshs'))
                               [ ((officeId, t), (dn, sn, t, maybe Set.empty Set.singleton ssh'))
                               | (E.Value officeId, (E.Value dn, E.Value sn, E.Value t, fmap unSchoolKey . E.unValue -> ssh')) <- syncs
                               ]
                return $ Map.elems syncs'

          colSynced = Colonnade.singleton (fromSortable . Sortable (Just "is-synced") $ i18nCell MsgExamUserSynchronised) $ \x -> cell . flip runReaderT x $ do
            syncs <- asks $ sortOn (Down . view _3) . toListOf resultSynchronised
            lastChange <- view $ resultExamResult . _entityVal . _examResultLastChanged
            user <- view $ resultUser . _entityVal
            isSynced <- view resultIsSynced
            let
              hasSyncs = has folded syncs

              syncs' = [ Right sync | sync@(_, _, t, _) <- syncs, t >  lastChange]
                    ++ [ Left lastChange ]
                    ++ [ Right sync | sync@(_, _, t, _) <- syncs, t <= lastChange]

              syncIcon :: Widget
              syncIcon
                | not isSynced
                , not hasSyncs
                = mempty
                | not isSynced
                = toWidget iconNotOK
                | otherwise
                = toWidget iconOK

              syncsModal :: Widget
              syncsModal = $(widgetFile "exam-office/exam-result-synced")
            lift $ bool id (flip modal $ Right syncsModal) hasSyncs syncIcon

          dbtColonnade :: Colonnade Sortable _ _
          dbtColonnade = mconcat
            [ dbSelect (applying _2) id $ return . view (resultExamResult . _entityKey)
            , colSynced
            , imapColonnade participantAnchor . anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
            , colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
            , colStudyFeatures resultStudyFeatures
            , Colonnade.singleton (fromSortable . Sortable (Just "occurrence-start") $ i18nCell MsgExamTime) $ \x -> cell . flip runReaderT x $ do
                start <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just
                end <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceEnd . _Just <> like examEnd . _Just
                lift $ maybe mempty (flip (formatTimeRangeW SelFormatDateTime) end) start
            , colExamResult (resultExamResult . _entityVal . _examResultResult)
            ]
          dbtSorting = mconcat
            [ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname)))
            , sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
            , sortOccurrenceStart (queryExamOccurrence . to (E.maybe (E.val examStart) E.just . (E.?. ExamOccurrenceStart)))
            , maybeOpticSortColumn sortExamResult (queryExamResult . to (E.^. ExamResultResult))
            , singletonMap "is-synced" . SortColumn $ view (queryIsSynced $ E.val uid)
            ]
          dbtFilter = mconcat
            [ fltrUserName' (queryUser . to (E.^. UserDisplayName))
            , fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
            , fltrExamResultPoints (queryExamResult . to (E.^. ExamResultResult) . to E.just)
            , singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid)
            , fltrRelevantStudyFeaturesTerms (to $
                \t -> ( E.val courseTerm
                      , views queryUser (E.^. UserId) t
                      ))
            , fltrRelevantStudyFeaturesDegree (to $
                \t -> ( E.val courseTerm
                      , views queryUser (E.^. UserId) t
                      ))
            , fltrRelevantStudyFeaturesSemester (to $
                \t -> ( E.val courseTerm
                      , views queryUser (E.^. UserId) t
                      ))

            ]
          dbtFilterUI = mconcat
            [ fltrUserNameUI'
            , fltrUserMatriculationUI
            , fltrExamResultPointsUI
            , \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised)
            , fltrRelevantStudyFeaturesTermsUI
            , fltrRelevantStudyFeaturesDegreeUI
            , fltrRelevantStudyFeaturesSemesterUI
            ]
          dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
          dbtParams = DBParamsForm
            { dbParamsFormMethod = POST
            , dbParamsFormAction = Just . SomeRoute $ CExamR tid ssh csh examn EGradesR
            , dbParamsFormAttrs  = []
            , dbParamsFormSubmit = FormSubmit
            , dbParamsFormAdditional = \csrf -> do
                let
                  actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData)
                  actionMap = Map.fromList
                    [ ( ExamUserMarkSynchronised
                      , pure ExamUserMarkSynchronisedData
                      )
                    ]
                (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
                let formRes = (, mempty) . First . Just <$> res
                return (formRes, formWgt)
            , dbParamsFormEvaluate = liftHandler . runFormPost
            , dbParamsFormResult   = id
            , dbParamsFormIdent    = def
            }
          dbtIdent :: Text
          dbtIdent = "exam-results"
          dbtCsvEncode = Just DBTCsvEncode
            { dbtCsvExportForm = ExamUserCsvExportData
              <$> apopt checkBoxField (fslI MsgExamUserMarkSynchronisedCsv & setTooltip MsgExamUserMarkSynchronisedCsvTip) (Just False)
            , dbtCsvDoEncode = \ExamUserCsvExportData{..} -> C.mapM $ \(E.Value k, row) -> do
                when csvEUserMarkSynchronised $ markSynced k
                return $ ExamUserTableCsv
                  (row ^. resultUser . _entityVal . _userSurname)
                  (row ^. resultUser . _entityVal . _userFirstName)
                  (row ^. resultUser . _entityVal . _userDisplayName)
                  (row ^. resultUser . _entityVal . _userMatrikelnummer)
                  (row ^. resultStudyFeatures)
                  (row ^? (resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just) . to utcToZonedTime)
                  (row ^. resultExamResult . _entityVal . _examResultResult)
            , dbtCsvName = unpack csvName
            , dbtCsvNoExportData = Nothing
            , dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv)
            , dbtCsvExampleData = Nothing
            }
          dbtCsvDecode = Nothing

          dbtExtraReps = []

      examUsersDBTableValidator = def & defaultSorting [SortAscBy "is-synced", SortAscBy "user-name"]
                                      & defaultPagesize PagesizeAll

      postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamResultId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamResultId)
      postprocess inp = do
        (First (Just act), regMap) <- inp
        let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap
        return (act, regSet)
    (usersResult, examUsersTable) <- over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable

    usersResult' <- formResultMaybe usersResult $ \case
      (ExamUserMarkSynchronisedData, selectedResults) -> do
        forM_ selectedResults markSynced
        return . Just $ do
          addMessageI Success $ MsgExamUserMarkedSynchronised (length selectedResults)
          redirect $ CExamR tid ssh csh examn EGradesR

    return ((usersResult', examUsersTable), exam)

  whenIsJust usersResult join

  closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EGradesR) eId
  hasUsers <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR

  siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading) $ do
    setTitleI $ prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading
    let examGradesExplanation = notificationWidget NotificationBroad Info $(i18nWidgetFile "exam-office/exam-grades-explanation")
    $(widgetFile "exam-office/exam-results")
