{-# 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


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{..} <- runDB $ get404 eId

  ((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
        }

  examClosed' <- for examClosed $ formatTime SelFormatDateTime

  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))
         `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
               `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
               `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
                           )
                         )
type ExamUserTableData = DBRow ( Entity ExamResult
                               , Entity User
                               , Maybe (Entity ExamOccurrence)
                               , Maybe (Entity StudyFeatures)
                               , Maybe (Entity StudyDegree)
                               , Maybe (Entity StudyTerms)
                               , Maybe (Entity ExamRegistration)
                               , Bool
                               , [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
                               )

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 2 1) . $(E.sqlLOJproj 4 4)

queryStudyFeatures :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
queryStudyFeatures = to $ $(E.sqlIJproj 3 1) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4)

queryStudyDegree :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
queryStudyDegree = to $ $(E.sqlIJproj 3 2) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4)

queryStudyField :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
queryStudyField = to $ $(E.sqlIJproj 3 3) . $(E.sqlLOJproj 2 2) . $(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

resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures)
resultStudyFeatures = _dbrOutput . _4 . _Just

resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree)
resultStudyDegree = _dbrOutput . _5 . _Just

resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms)
resultStudyField = _dbrOutput . _6 . _Just

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

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

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

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

data ExamUserTableCsv = ExamUserTableCsv
  { csvEUserSurname :: Text
  , csvEUserFirstName :: Text
  , csvEUserName :: Text
  , csvEUserMatriculation :: Maybe Text
  , csvEUserField :: Maybe Text
  , csvEUserDegree :: Maybe Text
  , csvEUserSemester :: Maybe Int
  , 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             )
    , ('csvEUserField               , MsgCsvColumnExamUserField                     )
    , ('csvEUserDegree              , MsgCsvColumnExamUserDegree                    )
    , ('csvEUserSemester            , MsgCsvColumnExamUserSemester                  )
    , ('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

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

    let
      participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
      participantLink partId = 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
            studyFeatures <- view queryStudyFeatures
            studyDegree <- view queryStudyDegree
            studyField <- view queryStudyField

            isSynced <- view . queryIsSynced $ E.val uid

            lift $ do
              E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
              E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
              E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
              E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
               E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
              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, studyFeatures, studyDegree, studyField, examRegistration, isSynced)
          dbtRowKey = views queryExamResult (E.^. ExamResultId)

          dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExamUserTableData
          dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
            (,,,,,,,,)
              <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view (_8 . _Value)
              <*> getSynchronised
            where
              getSynchronised :: ReaderT _ (MaybeT (YesodDB UniWorX)) [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
              getSynchronised = do
                resId <- view $ _1 . _entityKey
                syncs <- lift . 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)
            , emptyOpticColonnade (resultStudyField . _entityVal) colStudyTerms
            , emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
            , emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
            , 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 examShowGrades (resultExamResult . _entityVal . _examResultResult)
            ]
          dbtSorting = mconcat
            [ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname)))
            , sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
            , sortStudyTerms queryStudyField
            , sortStudyDegree queryStudyDegree
            , sortStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
            , sortOccurrenceStart (queryExamOccurrence . to (E.maybe (E.val examStart) E.just . (E.?. ExamOccurrenceStart)))
            , maybeOpticSortColumn (sortExamResult examShowGrades) (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))
            , fltrStudyTerms queryStudyField
            , fltrStudyDegree queryStudyDegree
            , fltrStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
            , fltrExamResultPoints examShowGrades (queryExamResult . to (E.^. ExamResultResult))
            , singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid)
            ]
          dbtFilterUI = mconcat
            [ fltrUserNameUI'
            , fltrUserMatriculationUI
            , fltrStudyTermsUI
            , fltrStudyDegreeUI
            , fltrStudyFeaturesSemesterUI
            , fltrExamResultPointsUI examShowGrades
            , \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgExamUserSynchronised)
            ]
          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) (Just True)
            , 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 ^? resultStudyField . _entityVal . to (\StudyTerms{..} -> fromMaybe (tshow studyTermsKey) $ studyTermsName <|> studyTermsShorthand))
                  (row ^? resultStudyDegree . _entityVal . to (\StudyDegree{..} -> fromMaybe (tshow studyDegreeKey) $ studyDegreeName <|> studyDegreeShorthand))
                  (row ^? resultStudyFeatures . _entityVal . _studyFeaturesSemester)
                  (row ^? (resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just) . to utcToZonedTime)
                  (row ^. resultExamResult . _entityVal . _examResultResult . to (fmap $ bool (Left . view passingGrade) Right examShowGrades))
            , dbtCsvName = unpack csvName
            , dbtCsvNoExportData = Nothing
            , dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv)
            }
          dbtCsvDecode = Nothing

      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

  siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading) $ do
    setTitleI $ prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading
    $(widgetFile "exam-office/exam-results")