module Handler.Course.Show
  ( getCShowR
  , getCRegisterTemplateR, courseRegisterTemplateSource
  ) where

import Import

import Utils.Course
import Utils.Form
import Handler.Utils
import Handler.Utils.Course
import Handler.Utils.Tutorial

import qualified Data.CaseInsensitive as CI

import qualified Data.Map as Map

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

import Handler.Course.Register

import qualified Data.Conduit.List as C

import Handler.Exam.List (mkExamTable)


getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do
  mbAid <- maybeAuthId
  now <- liftIO getCurrentTime
  (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) <- runDB . maybeT notFound $ do
    [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)]
       <- lift . E.select . E.from $
         \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
            E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse
                E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser
                E.&&. participant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
            E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
            E.where_ $ course E.^. CourseTerm      E.==. E.val tid
                 E.&&. course E.^. CourseSchool    E.==. E.val ssh
                 E.&&. course E.^. CourseShorthand E.==. E.val csh
            E.limit 1 -- we know that there is at most one match, but we tell the DB this info too
            let numParticipants :: E.SqlExpr (E.Value Int)
                numParticipants = E.subSelectCount . E.from $ \part ->
                  E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
                       E.&&. part E.^. CourseParticipantState E.==. E.val CourseParticipantActive
            return (course, courseIsVisible now course Nothing, school E.^. SchoolName, numParticipants, participant, courseAllocationRegistrationOpen now (course E.^. CourseId) Nothing)
    staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
      E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
      E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
      E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
      return ( lecturer E.^. LecturerType
             , user E.^. UserDisplayEmail, user E.^. UserDisplayName, user E.^. UserSurname)
    let partStaff :: (LecturerType, UserEmail, Text, Text) -> Either (UserEmail, Text, Text) (UserEmail, Text, Text)
        partStaff (CourseLecturer  ,name,surn,mail) = Right (name,surn,mail)
        partStaff (_courseAssistant,name,surn,mail) = Left (name,surn,mail)
        (assistants,lecturers) = partitionWith  partStaff $ map $(unValueN 4) staff
    correctors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
      E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
      E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
      E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
      return ( user E.^. UserDisplayEmail, user E.^. UserDisplayName, user E.^. UserSurname )
    tutors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(tutorial `E.InnerJoin` tutor `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
      E.on $ tutor E.^. TutorUser     E.==. user E.^. UserId
      E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
      E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
      E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
      return ( user E.^. UserDisplayEmail, user E.^. UserDisplayName, user E.^. UserSurname )
    mAllocation <- fmap (fmap entityVal . listToMaybe) . lift . E.select . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do
      E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
      E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cid
      E.limit 1
      return allocation
    hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile ->
      E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
    mApplicationTemplate <- runMaybeT $ do
      guard hasApplicationTemplate
      lift . lift . toTextUrl $ CourseR tid ssh csh CRegisterTemplateR
    mApplication <- lift . fmap (listToMaybe =<<) . for mbAid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] []
    news' <- lift $ selectList [ CourseNewsCourse ==. cid ] [ Desc CourseNewsVisibleFrom, Desc CourseNewsTitle, Desc CourseNewsSummary, Desc CourseNewsContent ]
    cTime <- NTop . Just <$> liftIO getCurrentTime
    news <- forMaybeM news' $ \(Entity nId n@CourseNews{..}) -> do
      cID <- encrypt nId :: MaybeT (MaybeT DB) CryptoUUIDCourseNews
      guardM . lift . lift . hasReadAccessTo $ CNewsR tid ssh csh cID CNShowR
      let visible = cTime >= NTop courseNewsVisibleFrom
      files' <- lift . lift . E.select . E.from $ \newsFile -> do
        E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
        return (E.isNothing $ newsFile E.^. CourseNewsFileContent, newsFile E.^. CourseNewsFileTitle)
      let files'' = files'
            & over (mapped . _1) E.unValue
            & over (mapped . _2) E.unValue
      lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit
      mayEditNews <- lift . lift . hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR
      mayDelete <- lift . lift . hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR

      files <- lift . lift $ forM files'' $ \f@(_isDir, fPath) -> fmap (f ,) . toTextUrl . CNewsR tid ssh csh cID $ CNFileR fPath
      archiveUrl <- lift . lift . toTextUrl $ CNewsR tid ssh csh cID CNArchiveR

      return (cID, n, visible, files, lastEditText, mayEditNews, mayDelete, archiveUrl)

    events' <- fmap (sortOn $ courseEventTime . entityVal . view _1) . lift . E.select . E.from $ \courseEvent -> do
      E.where_ $ courseEvent E.^. CourseEventCourse E.==. E.val cid
      let showRoom = maybe E.false (flip showCourseEventRoom courseEvent . E.val) mbAid
               E.||. E.not_ (courseEvent E.^. CourseEventRoomHidden)
      return (courseEvent, showRoom)
    events <- mapM (\(Entity evId ev, E.Value showRoom) -> (, ev, showRoom) <$> encrypt evId) events'

    hasSubmissionGroups <- lift . E.selectExists . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup) -> do
      E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
      E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid
    submissionGroup' <- lift . for mbAid $ \uid ->
      fmap (listToMaybe . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup) -> do
        E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
        E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid
        E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
        return $ submissionGroup E.^. SubmissionGroupName
    let submissionGroup = guardOnM (hasSubmissionGroups && is _Just registration) submissionGroup'

    mayReRegister <- lift . courseMayReRegister $ Entity cid course

    mayViewSheets <- lift . hasReadAccessTo $ CourseR tid ssh csh SheetListR
    sheets <- lift . E.select . E.from $ \sheet -> do
      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
      return $ sheet E.^. SheetName
    mayViewAnySheet <- lift . anyM sheets $ \(E.Value shn) -> hasReadAccessTo $ CSheetR tid ssh csh shn SShowR

    mayViewMaterials <- lift . hasReadAccessTo $ CourseR tid ssh csh MaterialListR
    materials <- lift . E.select . E.from $ \material -> do
      E.where_ $ material E.^. MaterialCourse E.==. E.val cid
      return $ material E.^. MaterialName
    mayViewAnyMaterial <- lift . anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR

    return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial))

  let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
  mDereg <- traverse (formatTime SelFormatDateTime) mDereg'

  cID <- encrypt cid :: Handler CryptoUUIDCourse
  mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (alloc, )
    <$> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
  regForm <- if
    | is _Just mbAid -> do
        (courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)
        (regWidget, regEnctype) <- generateFormPost $ renderAForm FormStandard courseRegisterForm'
        return $ wrapForm' regButton regWidget def
          { formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR
          , formEncoding = regEnctype
          , formSubmit = FormSubmit
          }
    | otherwise
      -> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR
  registrationOpen <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR

  MsgRenderer mr <- getMsgRenderer

  let
    tutorialDBTable = DBTable{..}
      where
        resultTutorial :: Lens' (DBRow (Entity Tutorial, Bool)) (Entity Tutorial)
        resultTutorial = _dbrOutput . _1
        resultShowRoom = _dbrOutput . _2
        
        dbtSQLQuery tutorial = do
          E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
          let showRoom = maybe E.false (flip showTutorialRoom tutorial . E.val) mbAid
                   E.||. E.not_ (tutorial E.^. TutorialRoomHidden)
          return (tutorial, showRoom)
        dbtRowKey = (E.^. TutorialId)
        dbtProj = traverse $ return . over _2 E.unValue
        dbtColonnade = dbColonnade $ mconcat
          [ sortable (Just "type") (i18nCell MsgTableTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType
          , sortable (Just "name") (i18nCell MsgTableTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
          , sortable (Just "tutors") (i18nCell MsgTableTutorialTutors) $ \(view $ resultTutorial . _entityKey -> tutid) -> sqlCell $ do
              tutTutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
                E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
                E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
                return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
              return [whamlet|
                       $newline never
                       <ul .list--iconless .list--inline .list--comma-separated>
                         $forall tutor <- tutTutors
                           <li>
                             ^{nameEmailWidget' tutor}
                     |]
          , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if
              | res ^. resultShowRoom -> maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res
              | otherwise -> i18nCell MsgTableTutorialRoomIsHidden & addCellClass ("explanation" :: Text)
          , sortable Nothing (i18nCell MsgTableTutorialTime) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> occurrencesCell tutorialTime
          , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterFrom
          , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterTo
          , sortable (Just "deregister-until") (i18nCell MsgTableTutorialDeregisterUntil) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialDeregisterUntil
          , sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \(view resultTutorial -> Entity tutid Tutorial{..}) -> case tutorialCapacity of
              Nothing -> mempty
              Just tutorialCapacity' -> sqlCell $ do
                freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe)
                  . E.select $ let numParticipants :: E.SqlExpr (E.Value Int)
                                   numParticipants = E.subSelectCount . E.from $ \participant ->
                                     E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
                                in return $ E.val tutorialCapacity' E.-. numParticipants
                return . toWidget $ tshow freeCapacity
          , sortable Nothing (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgTableActionsHead)) $ \(view resultTutorial -> Entity tutId Tutorial{..}) -> sqlCell $ do
              mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True
              isRegistered <- case mbAid of
                Nothing  -> return False
                Just uid -> existsBy $ UniqueTutorialParticipant tutId uid
              if
                | mayRegister -> do
                    (tutRegisterForm, tutRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
                    return $ wrapForm tutRegisterForm def
                      { formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR
                      , formEncoding = tutRegisterEnctype
                      , formSubmit = FormNoSubmit
                      }
                | isRegistered -> return [whamlet|_{MsgTutorialRegistered}|]
                | otherwise -> return mempty
          ]
        dbtSorting = Map.fromList
          [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
          , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
          , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
          , ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
          , ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo )
          , ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil )
          , ( "tutors"
            , SortColumn $ \tutorial -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do
                E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
                E.where_ $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
                return . E.min_ $ user E.^. UserSurname
            )
          ]
        dbtFilter = Map.empty
        dbtFilterUI = const mempty
        dbtStyle = def
        dbtParams = def
        dbtIdent :: Text
        dbtIdent = "tutorials"
        dbtCsvEncode = noCsvEncode
        dbtCsvDecode = Nothing
        dbtExtraReps = []

    tutorialDBTableValidator = def
      & defaultSorting [SortAscBy "type", SortAscBy "name"]
  (Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable

  (Any hasExams, examTable) <- runDB . mkExamTable $ Entity cid course

  let visibleNews = any (view _3) news
      showNewsFiles fs = and
        [ not $ null fs
        , length fs <= 3
        , all (views (_1 . _2) $ notElem pathSeparator) fs
        ]
      hiddenEventNotes = all (\(_,CourseEvent{..},_) -> is _Nothing courseEventNote) events
      Course{courseVisibleFrom,courseVisibleTo} = course
  mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR
  mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR
  mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR

  let heading = [whamlet|
          $newline never
          ^{courseName course}
          $if not courseVisible && mayEdit
            \ #{iconInvisible}
        |]

  siteLayout heading $ do
    setTitleI $ prependCourseTitle tid ssh csh (""::Text)
    $(widgetFile "course")

courseRegisterTemplateSource :: TermId -> SchoolId -> CourseShorthand -> ConduitT () CourseAppInstructionFile (YesodDB UniWorX) ()
courseRegisterTemplateSource tid ssh csh = (.| C.map entityVal) . E.selectSource . E.from $ \(courseAppInstructionFile `E.InnerJoin` course) -> do
  E.on $ course E.^. CourseId E.==. courseAppInstructionFile E.^. CourseAppInstructionFileCourse
  E.where_ $ course E.^. CourseTerm E.==. E.val tid
       E.&&. course E.^. CourseSchool E.==. E.val ssh
       E.&&. course E.^. CourseShorthand E.==. E.val csh
  return courseAppInstructionFile

getCRegisterTemplateR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
getCRegisterTemplateR tid ssh csh = do
  archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseApplicationTemplateArchiveName tid ssh csh
  serveSomeFiles archiveName $ courseRegisterTemplateSource tid ssh csh