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

import Import

import Data.Maybe (fromJust)

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

import qualified Data.Set as Set
import qualified Data.Map as Map

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


-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School, [Entity User], Maybe (Entity Allocation))

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

colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colDescription = sortable Nothing mempty
          $ \DBRow{ dbrOutput=(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 MsgCourseShort)
          $ \DBRow{ dbrOutput=(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 MsgTerm)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _) } ->
            anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|]

colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}, _, _) } ->
            anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|]

colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
          $ \DBRow{ dbrOutput=(_, _, registered, _, _, _) } -> tickmarkCell registered

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

course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int)
course2Participants (course `E.InnerJoin` _school) = E.subSelectCount . E.from $ \courseParticipant ->
    E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId

course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant ->
    E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
      E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid

makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) )
                     => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget
makeCourseTable whereClause colChoices psValidator = do
  muid <- lift maybeAuthId
  now <- liftIO getCurrentTime
  let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
      dbtSQLQuery qin@(course `E.InnerJoin` school) = do
        E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
        let participants = course2Participants qin
        let registered   = course2Registered muid qin
        E.where_ $ whereClause (course, participants, registered)
        return (course, participants, registered, school)
      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
      dbtProj :: DBRow _ -> MaybeT DB CourseTableData
      dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do
        lecturerList <- lift $ E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
        courseAlloc <- lift $ getBy (UniqueAllocationCourse $ entityKey course)
                          >>= traverse (getJustEntity . allocationCourseAllocation . entityVal)
        return (course, participants, registered, school, lecturerList, courseAlloc)
  snd <$> dbTable psValidator DBTable
    { dbtSQLQuery
    , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
    , dbtColonnade = colChoices
    , dbtProj
    , dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here
        [ ( "course",        SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseName)
        , ( "cshort",        SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseShorthand)
        , ( "term"  ,        SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseTerm)
        , ( "school",        SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolName)
        , ( "schoolshort",   SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand)
        , ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom)
        , ( "register-to",   SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo)
        , ( "members",       SortColumn   course2Participants   )
        , ( "registered",    SortColumn $ course2Registered muid)
        ]
    , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here
        [ ( "course", FilterColumn $ \(course `E.InnerJoin` _school:: CourseTableExpr) criterias -> if
                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
                | otherwise          -> course E.^. CourseName `E.in_` E.valList (Set.toList criterias)
          )
        , ( "cshort", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
                | otherwise          -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList criterias)
          )
        , ( "term"  , FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
                | otherwise          -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias)
          )
--         , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
--                 | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
--                 | otherwise          -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias)
--           )
        , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) ->
              emptyOrIn $ school E.^. SchoolName -- TODO: Refactor all?!
          )
        , ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
                | otherwise          -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias)
          )
        , ( "lecturer", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
                | otherwise          -> E.exists $ E.from $ \t -> do
                  user <- lecturerQuery (course E.^. CourseId) t
                  E.where_ $ E.any (E.hasInfix (user E.^. UserSurname) . E.val) (criterias :: Set.Set Text)
          )
        , ( "openregistration", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Bool) of
              Nothing -> E.val True
              Just b  -> 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
                             alloc allocation = do
                               E.where_ . E.exists . E.from $ \allocationCourse ->
                                 E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
                               return allocation
                             allocOpen allocation = (      E.maybe E.false (\f -> f E.<=. E.val now) (allocation E.^. AllocationRegisterFrom)
                                                     E.&&. E.maybe E.true  (\t -> E.val now E.<=. t) (allocation E.^. AllocationRegisterTo)
                                                    )
                                              E.||. (      courseOpen
                                                     E.&&. E.maybe E.false (\f -> f E.<=. E.val now) (allocation E.^. AllocationRegisterByCourse)
                                                    )
                         in (E.==. E.val b) $ (      courseOpen
                                               E.&&. E.not_ (E.exists . void $ E.from alloc)
                                              )
                                        E.||. E.exists (E.from $ E.where_ . allocOpen <=< alloc)
          )
        , ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of
              Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
              Just needle -> course2Registered muid tExpr E.==. E.val needle
          )
        , ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) 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.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
          )
        ]
    , dbtFilterUI = \mPrev -> mconcat $ catMaybes
      [ Just  $ prismAForm (singletonFilter "term" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTerm)
      , Just  $ prismAForm (singletonFilter "schoolshort" . maybePrism (_PathPiece . from _SchoolId)) mPrev $ aopt (hoistField lift schoolField) (fslI MsgCourseSchool)
      , Just  $ prismAForm (singletonFilter "lecturer") mPrev $ aopt textField (fslI MsgCourseLecturer)
      , Just  $ prismAForm (singletonFilter "search") mPrev $ aopt textField (fslI MsgCourseFilterSearch)
      , Just  $ prismAForm (singletonFilter "openregistration" . maybePrism _PathPiece) mPrev $ fmap (\x -> if isJust x && not (fromJust x) then Nothing else x) . aopt checkBoxField (fslI MsgCourseRegisterOpen)
      , muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgCourseFilterRegistered))
      ]
    , dbtStyle = def
      { dbsFilterLayout = defaultDBSFilterLayout
      , dbsTemplate = DBSTCourse (_dbrOutput . _1) (_dbrOutput . _5) (_dbrOutput . _3) (_dbrOutput . _4) (_dbrOutput . _6 . _Just)
      --                             ^ course          ^ lecturer list   ^ isRegistered    ^ school        ^ allocation
      }
    , dbtParams = def
    , dbtIdent = "courses" :: Text
    , dbtCsvEncode = noCsvEncode
    , dbtCsvDecode = Nothing
    }

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

getTermCurrentR :: Handler Html
getTermCurrentR = do
  termIds  <- runDB $ selectKeysList [TermActive ==. True] [Desc TermName]
  case fromNullable termIds of
    Nothing
      -> notFound
    Just (maximum -> tid)
      -> redirect (CourseListR, [("courses-term", toPathPiece tid)])  -- redirect avoids problematic breadcrumbs, headings, etc.

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)])