module Handler.News where

import Import

import Handler.Utils
import Handler.Utils.News

import Handler.SystemMessage

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

import qualified Data.Conduit.List as C (consume, mapMaybeM)
import qualified Data.Conduit.Combinators as C
import qualified Data.Conduit.Lift as C

import qualified Data.HashMap.Strict as HashMap

import Handler.Utils.Exam (showExamOccurrenceRoom)


getNewsR :: Handler Html
getNewsR = do
  muid <- maybeAuthId
  defaultLayout $ do
    setTitleI MsgNewsHeading

    newsSystemMessages

    when (is _Nothing muid) $
      notificationWidget NotificationBroad Info $(i18nWidgetFile "pitch")

    case muid of
      Just uid -> do
        newsUpcomingExams uid
        newsUpcomingSheets uid
      Nothing ->
        $(i18nWidgetFile "unauth-news")


newsSystemMessages :: Widget
newsSystemMessages = do
  now <- liftIO getCurrentTime

  showHidden <- isJust <$> lookupGetParam (toPathPiece GetHidden)

  let tellShown smId = liftHandler $ do
        cID <- encrypt smId :: Handler CryptoUUIDSystemMessage
        tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
          HashMap.singleton cID mempty{ userSystemMessageShown = Just now }
      mkHideForm smId SystemMessage{..} = liftHandler $ do
        cID <- encrypt smId
        hidden <- getSystemMessageState smId <&> \UserSystemMessageState{..} -> userSystemMessageHidden > Just systemMessageLastUnhide

        (btnView, btnEnctype) <- generateFormPost . buttonForm' $ bool [BtnSystemMessageHide] [BtnSystemMessageUnhide] hidden
        return $ wrapForm btnView def
          { formSubmit = FormNoSubmit
          , formEncoding = btnEnctype
          , formAction = Just . SomeRoute $ MessageHideR cID
          , formAttrs = [("class", "form--inline")]
          }
      checkHidden (smId, sm@SystemMessage{..}, trans) = do
        hidden <- getSystemMessageState smId <&> \UserSystemMessageState{..} -> userSystemMessageHidden > Just systemMessageLastUnhide

        tell $ Any hidden

        return $ guardOn (not hidden || showHidden) (smId, sm, trans, hidden)

  (messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $
       transPipe lift (selectKeys [] [])
    .| C.filterM (lift . hasReadAccessTo . MessageR <=< encrypt)
    .| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage smId)
    .| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo)
    .| C.mapMaybeM checkHidden
    .| C.iterM (\(smId, _, _, _) -> tellShown smId)
    .| C.mapM (\(smId, sm@SystemMessage{..}, trans, hidden) -> (sm, trans, hidden,,) <$> formatTime SelFormatDateTime (maybe id max systemMessageFrom systemMessageLastChanged) <*> mkHideForm smId sm)
    .| C.consume
  let messages = sortOn (\(SystemMessage{..}, _, _, _, _) -> (Down systemMessageManualPriority, Down $ maybe id max systemMessageFrom systemMessageLastChanged, systemMessageSeverity)) messages'

  hiddenUrl <- toTextUrl (NewsR, [(toPathPiece GetHidden, "")])

  unless (not anyHidden && null messages)
    $(widgetFile "news/system-messages")


newsUpcomingSheets :: UserId -> Widget
newsUpcomingSheets uid = do
  cTime <- liftIO getCurrentTime
  let noActiveToCutoff = toMidnight . addGregorianDurationRollOver (scaleCalendarDiffDays (-1) calendarMonth) $ utctDay cTime

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

        let showSheetNoActiveTo =
                    E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetActiveFrom)
              E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetVisibleFrom)
              E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetHintFrom)
              E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetSolutionFrom)

        E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
             E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
             E.&&. E.maybe showSheetNoActiveTo (E.>=. E.val cTime) (sheet E.^. SheetActiveTo)

        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 (Maybe UTCTime)
                                             , E.Value (Maybe SubmissionId)
                                             ))
                                      (DBCell Handler ())
      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 mDeadline, _) } ->
            maybe mempty (cell . formatTimeW SelFormatDateTime) mDeadline
        , 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"]
                      & forceFilter "may-access" (Any True)
  sheetTable <- liftHandler . runDB $ dbTableWidget' validator DBTable
    { dbtSQLQuery  = tableData
    , dbtRowKey    = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
    , dbtColonnade = colonnade
    , dbtProj      = return
    , 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    =  mconcat
          [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
              let (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) = dbrOutput :: ( E.Value (Key Term)
                                                                                            , E.Value SchoolId
                                                                                            , E.Value CourseShorthand
                                                                                            , E.Value SheetName
                                                                                            , E.Value (Maybe UTCTime)
                                                                                            , E.Value (Maybe SubmissionId)
                                                                                            )
               in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn SShowR) :: DB Bool
          ]
    , dbtFilterUI  = mempty
    , dbtStyle     = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
    , dbtParams    = def
    , dbtIdent     = "upcoming-sheets" :: Text
    , dbtCsvEncode = noCsvEncode
    , dbtCsvDecode = Nothing
    , dbtExtraReps = []
    }
  $(widgetFile "news/upcomingSheets")


newsUpcomingExams :: UserId -> Widget
newsUpcomingExams uid = do
  now <- liftIO getCurrentTime
  ((Any hasExams, examTable), warningDays) <- liftHandler . runDB $ do
    User {userWarningDays} <- get404 uid
    let fortnight = addUTCTime userWarningDays now
    let -- code copied and slightly adapted from Handler.Course.getCShowR:
      examDBTable = DBTable{..}
        where
          -- for ease of refactoring:
          queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
          queryExam   = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
          lensCourse     = _1
          lensExam       = _2
          lensRegister   = _3 . _Just
          lensOccurrence = _4 . _Just
          lensShowRoom   = _5 . _Value

          dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do
            E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId)
            E.on $ register E.?. ExamRegistrationExam       E.==. E.just (exam E.^. ExamId)
                  E.&&. register E.?. ExamRegistrationUser  E.==. E.just (E.val uid)
            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.&&. participant E.^. CourseParticipantState  E.==. E.val CourseParticipantActive
            let regToWithinFortnight = exam E.^. ExamRegisterTo    E.<=. E.just (E.val fortnight)
                                E.&&.  exam E.^. ExamRegisterTo    E.>=. E.just (E.val now)
                                E.&&.  E.isNothing (register E.?. ExamRegistrationId)
                startExamFortnight   = exam E.^. ExamStart         E.<=. E.just (E.val fortnight)
                                E.&&.  exam E.^. ExamStart         E.>=. E.just (E.val now)
                                E.&&.  E.isJust (register E.?. ExamRegistrationId)
                startOccurFortnight  = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight)
                                E.&&.  occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now)
                                E.&&.  E.isJust (register E.?. ExamRegistrationId)
                earliestOccurrence = E.subSelectMaybe $ E.from $ \occ -> do
                                E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId
                                    E.&&.  occ E.^. ExamOccurrenceStart E.>=. E.val now
                                return $ E.min_ $ occ E.^. ExamOccurrenceStart
                startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId)
                          E.&&. earliestOccurrence E.<=. E.just (E.val fortnight)
                          -- E.&&. earliestOccurrence E.>=. E.just (E.val now)
            E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest
            let showRoom = showExamOccurrenceRoom (E.val uid) occurrence
                     E.||. E.maybe E.false E.not_ (occurrence E.?. ExamOccurrenceRoomHidden)
            return (course, exam, register, occurrence, showRoom)
          dbtRowKey = queryExam >>> (E.^. ExamId)
          dbtProj = return
          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 } ->
                if  | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
                      -> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd
                    | Entity _ Exam{..} <- view lensExam dbrOutput
                    , Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd
                    | otherwise -> mempty
            {- 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) <- liftHandler . 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 _ Exam{..} = view lensExam   dbrOutput
                    Entity _ Course{..} = view lensCourse dbrOutput
                mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
                let isRegistered = has lensRegister dbrOutput
                    label   = bool MsgExamNotRegistered MsgExamRegistered isRegistered
                    examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR
                if  | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
                    | otherwise   -> return [whamlet|_{label}|]
            , sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } ->
                if  | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
                      -> if | view lensShowRoom dbrOutput -> maybe (i18nCell MsgExamOccurrenceRoomIsUnset) roomReferenceCell examOccurrenceRoom
                            | otherwise -> i18nCell MsgExamOccurrenceRoomIsHidden & addCellClass ("explanation" :: Text)
                    | otherwise -> mempty
            ]
          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 = mconcat
            [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
                let Entity _ Exam{..}   = view lensExam   dbrOutput
                    Entity _ Course{..} = view lensCourse dbrOutput
                in (==b) <$> hasReadAccessTo (CExamR courseTerm courseSchool courseShorthand examName EShowR) :: DB Bool
            ]
          dbtFilterUI = const mempty
          dbtStyle = def
          dbtParams = def
          dbtIdent :: Text
          dbtIdent = "exams"
          dbtCsvEncode = noCsvEncode
          dbtCsvDecode = Nothing
          dbtExtraReps = []

      examDBTableValidator = def
        & defaultSorting [SortAscBy "time"]
        & forceFilter "may-access" (Any True)

    (, userWarningDays) <$> dbTable examDBTableValidator examDBTable

  $(widgetFile "news/upcomingExams")


