module Handler.Home where

import Import

import Utils.Lens
import Handler.Utils
import Handler.Utils.Table.Cells


import qualified Data.Map as Map
import Database.Esqueleto.Utils.TH
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E

getHomeR :: Handler Html
getHomeR = do
  muid <- maybeAuthId
  upcomingExamsWidget <- for muid $ runDB . homeUpcomingExams
  defaultLayout $ do
    setTitleI MsgHomeHeading
    fromMaybe mempty upcomingExamsWidget
    maybe mempty homeUpcomingSheets muid
    homeOpenCourses


homeOpenCourses :: Widget
homeOpenCourses = do
  cTime <- liftIO getCurrentTime
  let tableData :: E.SqlExpr (Entity Course)
                  -> E.SqlQuery (E.SqlExpr (Entity Course))
      tableData course = do
            E.where_ $ E.not_ (E.isNothing $ course E.^. CourseRegisterFrom) --   DO: do this with isAuthorized in dbtProj
                E.&&.  (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime))
                E.&&. (       E.isNothing (course E.^. CourseRegisterTo)
                        E.||. course E.^. CourseRegisterTo E.>=. E.val (Just cTime)
                      )
            return course

      colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
      colonnade = mconcat
        [ -- dbRow
          sortable (Just "term")   (i18nCell MsgTerm) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
            msgCell $ courseTerm course
        , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
            msgCell $ courseSchool course
        , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> do
            let tid = courseTerm      course
                ssh = courseSchool    course
                csh = courseShorthand course
            anchorCell (CourseR tid ssh csh CShowR) csh
        , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
            cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
        ]
  courseTable <- liftHandlerT . runDB $ dbTableWidget' def DBTable
    { dbtSQLQuery  = tableData
    , dbtRowKey    = (E.^. CourseId)
    , dbtColonnade = colonnade
    , dbtProj      = return
    , dbtSorting   = Map.fromList
                      [ ( "term"
                        , SortColumn $ \course -> course E.^. CourseTerm
                        )
                      , ( "school"
                        , SortColumn $ \course -> course E.^. CourseSchool
                        )
                      , ( "course"
                        , SortColumn $ \course -> course E.^. CourseShorthand
                        )
                      , ( "deadline"
                        , SortColumn $ \course -> course E.^. CourseRegisterTo
                        )
                      ]
    , dbtFilter    =  mempty {- [ ( "term"
                        , FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if
                            | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
                            | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
                        )
                        ] -}
    , dbtFilterUI  = mempty
    , dbtStyle     = def
    , dbtParams    = def
    , dbtIdent     = "open-courses" :: Text
    , dbtCsvEncode = noCsvEncode
    , dbtCsvDecode = Nothing
    }
  $(widgetFile "home/openCourses")

homeUpcomingSheets :: UserId -> Widget
homeUpcomingSheets uid = do
  cTime <- liftIO getCurrentTime
  let tableData :: E.LeftOuterJoin
                        (E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet)))
                        (E.InnerJoin (E.SqlExpr (Maybe (Entity Submission))) (E.SqlExpr (Maybe (Entity SubmissionUser))))
                  -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
                                , E.SqlExpr (E.Value SchoolId)
                                , E.SqlExpr (E.Value CourseShorthand)
                                , E.SqlExpr (E.Value SheetName)
                                , E.SqlExpr (E.Value UTCTime)
                                , E.SqlExpr (E.Value (Maybe SubmissionId)))
      tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do
        E.on $ submission E.?. SubmissionId    E.==. subuser      E.?. SubmissionUserSubmission
         E.&&. E.just (E.val uid)              E.==. subuser      E.?. SubmissionUserUser
        E.on $ submission E.?. SubmissionSheet E.==. E.just(sheet E.^. SheetId)
        E.on $ course     E.^. CourseId        E.==. sheet        E.^. SheetCourse
        E.on $ course     E.^. CourseId        E.==. participant  E.^. CourseParticipantCourse
        E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
            E.&&. sheet E.^. SheetActiveTo E.>=. E.val cTime
        return
          ( course  E.^. CourseTerm
          , course  E.^. CourseSchool
          , course  E.^. CourseShorthand
          , sheet   E.^. SheetName
          , sheet   E.^. SheetActiveTo
          , submission E.?. SubmissionId
          )

      colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term)
                                             , E.Value SchoolId
                                             , E.Value CourseShorthand
                                             , E.Value SheetName
                                             , E.Value UTCTime
                                             , E.Value (Maybe SubmissionId)
                                             ))
                                      (DBCell (HandlerT UniWorX IO) ())
      colonnade = mconcat
        [ -- dbRow
          -- TOOD: sortable (Just "term")   (textCell MsgTerm)   $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } ->
          sortable (Just "term")   (i18nCell MsgTerm)   $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } ->
            textCell $ toMessage tid
        , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } ->
            textCell $ toMessage ssh
        , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } ->
            anchorCell (CourseR tid ssh csh CShowR) csh
        , sortable (Just "sheet")  (i18nCell MsgSheet)  $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } ->
            anchorCell (CSheetR tid ssh csh shn SShowR) shn
        , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
            cell $ formatTime SelFormatDateTime deadline >>= toWidget
        , sortable (Just "done")   (i18nCell MsgDone)   $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } ->
            case mbsid of
              Nothing    -> cell $ do
                let submitRoute = CSheetR tid ssh csh shn SubmissionNewR
                whenM (hasWriteAccessTo submitRoute) $
                  modal [whamlet|_{MsgMenuSubmissionNew}|] . Left $ SomeRoute submitRoute
              (Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
                                        (hasTickmark True)
        ]
  let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
  sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable
    { dbtSQLQuery  = tableData
    , dbtRowKey    = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
    , dbtColonnade = colonnade
    , dbtProj      = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
                        -> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)
    , dbtSorting   = Map.fromList
                      [ ( "term"
                        , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm
                        )
                      , ( "school"
                        , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseSchool
                        )
                      , ( "course"
                        , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
                        )
                      , ( "sheet"
                        , SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
                        )
                      , ( "deadline"
                        , SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
                        )
                      , ( "done"
                        , SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` _ `E.LeftOuterJoin` (subm `E.InnerJoin` _)) -> E.isNothing $ subm E.?. SubmissionId
                        )
                      ]
    , dbtFilter    =  mempty {- [ ( "term"
                        , FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if
                            | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
                            | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
                        )
                        ] -}
    , dbtFilterUI  = mempty
    , dbtStyle     = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
    , dbtParams    = def
    , dbtIdent     = "upcoming-sheets" :: Text
    , dbtCsvEncode = noCsvEncode
    , dbtCsvDecode = Nothing
    }
  $(widgetFile "home/upcomingSheets")



homeUpcomingExams :: UserId -> DB Widget
homeUpcomingExams uid = do
  now <- liftIO getCurrentTime
  let fortnight = addWeeks 2 now
  let -- code copied and slightly adapted from Handler.Course.getCShowR:
    examDBTable = DBTable{..}
      where
        -- for ease of refactoring:
        queryCourse = $(sqlIJproj 2 1)
        queryExam   = $(sqlIJproj 2 2)
        lensCourse  = _1
        lensExam    = _2

        dbtSQLQuery (course `E.InnerJoin` exam) = do
          E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
          E.where_ $ E.exists $ E.from $ \participant ->
            E.where_ $ participant E.^. CourseParticipantUser   E.==. E.val uid
              E.&&.    participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
          E.where_ $ E.isJust (exam E.^. ExamRegisterFrom)
                     E.&&.     exam E.^. ExamRegisterFrom  E.<=. E.just (E.val fortnight)
          E.where_ $ E.isJust (exam E.^. ExamEnd)
                     E.&&.     exam E.^. ExamEnd           E.>=. E.just (E.val now)
          return (course, exam)
        dbtRowKey = queryExam >>> (E.^. ExamId)
        dbtProj r@DBRow{ dbrOutput } = do
          let Entity _ Exam{..}   = view lensExam   dbrOutput
              Entity _ Course{..} = view lensCourse dbrOutput
          guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights
          return r
        dbtColonnade = dbColonnade $ mconcat
          [ sortable (Just "term") (i18nCell MsgTerm)           $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
              msgCell courseTerm
          , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
              msgCell  courseSchool
          , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
              anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand)
          -- continue here
          , sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do
              let Entity _ Exam{..}   = view lensExam   dbrOutput
                  Entity _ Course{..} = view lensCourse dbrOutput
              indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName
          , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
          , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
          , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
          {- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems.
             Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers.
          , sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do
              let Entity eId Exam{..}   = view lensExam   dbrOutput
                  Entity _ Course{..} = view lensCourse dbrOutput
              mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
              isRegistered <- existsBy $ UniqueExamRegistration eId uid
              if
                | mayRegister -> do
                    (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
                    return $ wrapForm examRegisterForm def
                      { formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR
                      , formEncoding = examRegisterEnctype
                      , formSubmit = FormNoSubmit
                      }
                | isRegistered -> return [whamlet|_{MsgExamRegistered}|]
                | otherwise -> return mempty
            -}
          , sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do
              let Entity eId Exam{..} = view lensExam   dbrOutput
                  Entity _ Course{..} = view lensCourse dbrOutput
              mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
              isRegistered <- existsBy $ UniqueExamRegistration eId uid
              let label   = bool MsgExamNotRegistered MsgExamRegistered isRegistered
                  examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR
              if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
                 | otherwise   -> return [whamlet|_{label}|]
          ]
        dbtSorting = Map.fromList
          [ ("demo-both",     SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))
          , ("term",          SortColumn $ queryCourse >>> (E.^. CourseTerm      ))
          , ("school",        SortColumn $ queryCourse >>> (E.^. CourseSchool    ))
          , ("course",        SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
          , ("name",          SortColumn $ queryExam >>> (E.^. ExamName ))
          , ("time",          SortColumn $ queryExam >>> (E.^. ExamStart ))
          , ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
          , ("register-to",   SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
          , ("visible",       SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
          , ("registered",    SortColumn $ queryExam >>> (\exam ->
              E.exists $ E.from $ \registration -> do
                E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
                E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
            ))
          ]
        dbtFilter = Map.empty
        dbtFilterUI = const mempty
        dbtStyle = def
        dbtParams = def
        dbtIdent :: Text
        dbtIdent = "exams"
        dbtCsvEncode = noCsvEncode
        dbtCsvDecode = Nothing

    examDBTableValidator = def
      & defaultSorting [SortAscBy "time"]
  (Any hasExams, examTable) <- dbTable examDBTableValidator examDBTable
  return $(widgetFile "home/upcomingExams")


