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

module Handler.Course.List
  ( makeCourseTable
  , getCourseListR
  , getTermCurrentR
  , getTermSchoolCourseListR
  , getTermCourseListR
  ) where

import Import

import Data.Maybe (fromJust)

import Utils.Course
import Utils.Form
-- import Utils.DB
import Handler.Utils hiding (colSchoolShort)

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

import qualified Data.CaseInsensitive as CI
import qualified Data.Text as Text
import qualified Data.Set as Set


type CourseTableData = DBRow
  ( Entity Course
  , Bool -- isRegistered
  , Entity School
  , [Entity User]
  , Maybe (Entity Allocation)
  , Bool -- mayEditCourse
  )

resultCourse :: Lens' CourseTableData (Entity Course)
resultCourse = _dbrOutput . _1

resultSchool :: Lens' CourseTableData (Entity School)
resultSchool = _dbrOutput . _3
  
resultIsRegistered :: Lens' CourseTableData Bool
resultIsRegistered = _dbrOutput . _2

resultLecturers :: Traversal' CourseTableData (Entity User)
resultLecturers = _dbrOutput . _4 . traverse

resultAllocation :: Traversal' CourseTableData (Entity Allocation)
resultAllocation = _dbrOutput . _5 . _Just

resultMayEditCourse :: Lens' CourseTableData Bool
resultMayEditCourse = _dbrOutput . _6


type CourseTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School))
     `E.LeftOuterJoin`  E.SqlExpr (Maybe (Entity Allocation))

queryCourse :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (Entity Course))
queryCourse = to $ $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 2 1)

querySchool :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (Entity School))
querySchool = to $ $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 1)

queryAllocation :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (Maybe (Entity Allocation)))
queryAllocation = to   $(E.sqlLOJproj 2 2)

queryParticipants :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Int))
queryParticipants = queryCourse . to (E.^. CourseId) . to numCourseParticipants

queryIsRegistered :: Maybe UserId
                  -> AuthTagActive
                  -> IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Bool))
queryIsRegistered muid ata = queryCourse . to (E.^. CourseId) . to (isCourseParticipant muid ata)

queryMayViewCourse :: Maybe UserId
                   -> AuthTagActive
                   -> UTCTime -- ^ @now@
                   -> IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Bool))
queryMayViewCourse muid ata now = to . runReader $ do
  course <- view queryCourse
  allocation <- view queryAllocation

  return $ mayViewCourse muid ata now course (allocation E.?. AllocationId)

queryIsEditor :: Maybe UserId
              -> AuthTagActive
              -> IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Bool))
queryIsEditor muid ata = queryCourse . to (mayEditCourse muid ata)


colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgFilterCourse)
          $ \(view resultCourse -> Entity _ Course{..}) ->
            anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
              [whamlet|_{courseName}|]

colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colDescription = sortable Nothing mempty
          $ \(view resultCourse -> Entity _ Course{..}) ->
            case courseDescription of
              Nothing      -> mempty
              (Just descr) -> cell $ modal (toWidget $ hasComment True) (Right $ toWidget descr)

colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colCShort = sortable (Just "cshort") (i18nCell MsgFilterCourseShort)
          $ \(view resultCourse -> Entity _ Course{..}) ->
            anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseShorthand}|]

colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgFilterTerm)
          $ \(view resultCourse -> Entity _ Course{..}) ->
            anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|]

colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgFilterCourseSchoolShort) $ \res
  -> let Entity _ Course{..} = res ^. resultCourse
         Entity _ School{..} = res ^. resultSchool
      in anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|]

colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colRegistered = sortable (Just "registered") (i18nCell MsgFilterRegistered) $ views resultIsRegistered tickmarkCell


data AllocationSearch
  = AllocationSearchNoAllocation
  | AllocationSearchMatch TermId SchoolId AllocationShorthand
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

instance PathPiece AllocationSearch where
  toPathPiece AllocationSearchNoAllocation = "no-allocation"
  toPathPiece (AllocationSearchMatch tid ssh ash) = pathPieceJoined "-" # [toPathPiece tid, toPathPiece ssh, toPathPiece ash]
  fromPathPiece t
    | CI.mk (Text.strip t) == "no-allocation" = pure AllocationSearchNoAllocation
    | Just [tid, ssh, ash] <- t ^? pathPieceJoined "-"
    = AllocationSearchMatch <$> fromPathPiece tid <*> fromPathPiece ssh <*> fromPathPiece ash
    | otherwise = mzero


makeCourseTable :: (ToSortable h, Functor h)
                => Colonnade h CourseTableData (DBCell Handler ()) -> PSValidator Handler () -> DB Widget
makeCourseTable colChoices psValidator' = do
  let psValidator = psValidator'
        & forceFilter "may-read" (Any True)

  muid <- lift maybeAuthId
  now <- liftIO getCurrentTime
  ata <- getSessionActiveAuthTags

  MsgRenderer mr <- getMsgRenderer
  let allocSearchNoAllocOption = Option
        { optionDisplay = mr MsgFilterCourseAllocationNone
        , optionInternalValue
        , optionExternalValue = toPathPiece optionInternalValue
        }
        where optionInternalValue = AllocationSearchNoAllocation
  allocationSearchOptions <- mkOptionList . (allocSearchNoAllocOption :) <$> do
    allocs <- E.select . E.from $ \allocation -> do
      E.orderBy [ E.desc $ allocation E.^. AllocationTerm
                , E.asc $ allocation E.^. AllocationSchool
                , E.asc $ allocation E.^. AllocationName
                ]
      return ( allocation E.^. AllocationTerm, allocation E.^. AllocationSchool, allocation E.^. AllocationShorthand
             , allocation E.^. AllocationName
             )
    return . flip map allocs $ \(E.Value tid, E.Value ssh, E.Value ash, E.Value aname)
      -> let optionInternalValue = AllocationSearchMatch tid ssh ash
          in Option
               { optionDisplay = mr $ MsgFilterCourseAllocationOption tid ssh aname
               , optionInternalValue
               , optionExternalValue = toPathPiece optionInternalValue
               }
  
  let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
      dbtSQLQuery = runReaderT $ do
        course <- view queryCourse
        school <- view querySchool
        allocation <- view queryAllocation

        lift . E.on . E.exists . E.from $ \allocationCourse ->
          E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
               E.&&. allocation E.?. AllocationId E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
        lift . E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId

        registered <- view $ queryIsRegistered muid ata
        isEditor <- view $ queryIsEditor muid ata

        return (course, registered, school, allocation, isEditor)
      lecturerQuery cid (user `E.InnerJoin` lecturer) = do
        E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
        E.where_ $ cid E.==. lecturer E.^. LecturerCourse
             E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer
        return user
      isCourseAdminQuery cid (user `E.InnerJoin` lecturer) = do
        E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
        E.where_ $ cid E.==. lecturer E.^. LecturerCourse
        return user
      dbtProj :: _ CourseTableData
      dbtProj = dbtProjSimple $ \(course, E.Value registered, school, allocation, E.Value isEditor) -> do
        lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
        return (course, registered, school, lecturerList, allocation, isEditor)
  
  dbTableWidget' psValidator DBTable
    { dbtSQLQuery
    , dbtRowKey = views queryCourse (E.^. CourseId)
    , dbtColonnade = colChoices
    , dbtProj
    , dbtSorting = mconcat
      [ singletonMap "course"         . SortColumn $ views queryCourse (E.^. CourseName)
      , singletonMap "cshort"         . SortColumn $ views queryCourse (E.^. CourseShorthand)
      , singletonMap "term"           . SortColumn $ views queryCourse (E.^. CourseTerm)
      , singletonMap "school"         . SortColumn $ views querySchool (E.^. SchoolName)
      , singletonMap "schoolshort"    . SortColumn $ views querySchool (E.^. SchoolShorthand)
      , singletonMap "register-from"  . SortColumn $ views queryCourse (E.^. CourseRegisterFrom)
      , singletonMap "register-to"    . SortColumn $ views queryCourse (E.^. CourseRegisterTo)
      , singletonMap "members"        . SortColumn $ view queryParticipants
      , singletonMap "registered"     . SortColumn . view $ queryIsRegistered muid ata
      ]
    , dbtFilter = mconcat
      [ singletonMap "may-read" . FilterColumn $ \t (Any b) -> views (queryMayViewCourse muid ata now) (E.==. E.val b) t
      , singletonMap "course" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseName)
      , singletonMap "cshort" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseShorthand)
      , singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm)
      , singletonMap "school" . FilterColumn . E.mkExactFilter $ views querySchool (E.^. SchoolName)
      , singletonMap "schoolshort" . FilterColumn . E.mkExactFilter $ views querySchool (E.^. SchoolShorthand)
      , singletonMap "lecturer" . FilterColumn . E.mkExistsFilter $ \t (c :: Text) -> E.from $ \t' -> do
          user <- isCourseAdminQuery (view queryCourse t E.^. CourseId) t'
          E.where_ $ user E.^. UserDisplayName `E.hasInfix` E.val c
      , singletonMap "openregistration" . FilterColumn . E.mkExactFilterLast . runReader $ do
          course <- view queryCourse
          allocation <- view queryAllocation

          let regTo   = course E.^. CourseRegisterTo
              regFrom = course E.^. CourseRegisterFrom
              courseOpen = E.maybe E.false (\f -> f E.<=. E.val now) regFrom
                     E.&&. E.maybe E.true  (\t -> E.val now E.<=. t) regTo
              allocOpen = (       E.maybe E.false (\f -> f E.<=. E.val now) (E.joinV $ allocation E.?. AllocationRegisterFrom)
                            E.&&. E.maybe E.true  (\t -> E.val now E.<=. t) (E.joinV $ allocation E.?. AllocationRegisterTo)
                          )
                    E.||. (       courseOpen
                            E.&&. E.maybe E.false (\f -> f E.<=. E.val now) (E.joinV $ allocation E.?. AllocationRegisterByCourse)
                          )

          return $ (       courseOpen
                     E.&&. E.isNothing (allocation E.?. AllocationId)
                   )
             E.||. (       allocOpen
                     E.&&. E.isJust (allocation E.?. AllocationId)
                   )
      , singletonMap "registered" . FilterColumn . E.mkExactFilterLast . view $ queryIsRegistered muid ata
      , singletonMap "search" . FilterColumn $ \(view queryCourse -> course) criterion -> case getLast (criterion :: Last Text) of
          Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
          Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
                   E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
                   E.||. (E.maybe (E.val mempty) (E.castString . esqueletoMarkupOutput) (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
      , singletonMap "allocation" . FilterColumn $ \row (criteria :: Set AllocationSearch) -> if
          | Set.null criteria -> E.true
          | otherwise -> flip E.any criteria $ \case
              AllocationSearchNoAllocation -> E.isNothing $ view queryAllocation row E.?. AllocationId
              AllocationSearchMatch tid ssh ash
                ->       view queryAllocation row E.?. AllocationTerm E.==. E.justVal tid
                   E.&&. view queryAllocation row E.?. AllocationSchool E.==. E.justVal ssh
                   E.&&. view queryAllocation row E.?. AllocationShorthand E.==. E.justVal ash
      ]
    , dbtFilterUI = \mPrev -> mconcat $ catMaybes
      [ pure $ prismAForm (singletonFilter "term" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm)
      , pure $ prismAForm (singletonFilter "schoolshort" . maybePrism (_PathPiece . from _SchoolId)) mPrev $ aopt (hoistField lift schoolField) (fslI MsgTableCourseSchool)
      , pure $ prismAForm (singletonFilter "lecturer") mPrev $ aopt textField (fslI MsgCourseLecturer)
      , pure $ prismAForm (singletonFilter "search") mPrev $ aopt textField (fslI MsgFilterCourseSearch)
      , pure $ prismAForm (singletonFilter "openregistration" . maybePrism _PathPiece) mPrev $ fmap (\x -> if isJust x && not (fromJust x) then Nothing else x) . aopt checkBoxField (fslI MsgFilterCourseRegisterOpen)
      , guardOn (is _Just muid)
             $ prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterCourseRegistered))
      , pure $ prismAForm (singletonFilter "allocation" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return allocationSearchOptions) (fslI MsgFilterCourseAllocation)
      ]
    , dbtStyle = def
      { dbsFilterLayout = defaultDBSFilterLayout
      , dbsTemplate = DBSTCourse resultCourse resultLecturers resultIsRegistered resultSchool resultAllocation resultMayEditCourse
      }
    , dbtParams = def
    , dbtIdent = "courses" :: Text
    , dbtCsvEncode = noCsvEncode
    , dbtCsvDecode = Nothing
    , dbtExtraReps = []
    }

getCourseListR :: Handler Html
getCourseListR = do
  muid <- maybeAuthId
  let colonnade = widgetColonnade $ mconcat
        [ colCourse -- colCourseDescr
        , colDescription
        , colSchoolShort
        , colTerm
        , colCShort
        , maybe mempty (const colRegistered) muid
        ]
      validator = def
        & defaultSorting [SortDescBy "term",SortAscBy "course"]
  coursesTable <- runDB $ makeCourseTable colonnade validator
  defaultLayout $ do
    setTitleI MsgCourseListTitle
    $(widgetFile "courses")

getTermCurrentR :: Handler Html
getTermCurrentR = maybeT notFound $ do
  currentTerm <- MaybeT $ runDB getCurrentTerm
  redirect (CourseListR, [("courses-term", toPathPiece currentTerm)])

getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html
getTermSchoolCourseListR tid ssh = redirect (CourseListR, [("courses-term", toPathPiece tid), ("courses-schoolshort", toPathPiece ssh)])

getTermCourseListR :: TermId -> Handler Html
getTermCourseListR tid = redirect (CourseListR, [("courses-term", toPathPiece tid)])