{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.Course where

import Import

import Utils.Lens
import Utils.Form
-- import Utils.DB
import Handler.Utils
import Handler.Utils.Course
import Handler.Utils.Delete
import Handler.Utils.Database
import Handler.Utils.Table.Cells
import Handler.Utils.Table.Columns
import Database.Esqueleto.Utils

-- import Data.Time
-- import qualified Data.Text as T
import Data.Function ((&))
-- import Yesod.Form.Bootstrap3

import Data.Monoid (Last(..))

import Data.Maybe (fromJust)
import qualified Data.Set as Set
import qualified Data.Map as Map

import qualified Database.Esqueleto as E


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

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

-- colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
-- colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do
--     course <- view $ _dbrOutput . _1 . _entityVal
--     return $ courseCell course

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 _ CourseTableData (DBCell m a)
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
            anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|]

-- colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
-- colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
--           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend
--             ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
--             ( case courseDescription of
--                 Nothing      -> mempty
--                 (Just descr) -> cell
--                   [whamlet|
--                     $newline never
--                     <div>
--                       ^{modal "Beschreibung" (Right $ toWidget descr)}
--                   |]
--             )

colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgTerm)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
            anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|]

colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
            anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|]

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

colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
            maybe mempty dateTimeCell courseRegisterFrom
            -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget

colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
            maybe mempty dateTimeCell courseRegisterTo

colMembers :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colMembers = sortable (Just "members") (i18nCell MsgCourseMembers)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of
              Nothing -> MsgCourseMembersCount currentParticipants
              Just limit -> MsgCourseMembersCountLimited currentParticipants limit

colRegistered :: IsDBTable m a => Colonnade _ 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 Int64)
course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \courseParticipant -> do
    E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
    return (E.countRows :: E.SqlExpr (E.Value Int64))

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
  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)
      dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
      dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
  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)
          )
        , ( "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 "search") mPrev $ aopt (searchField True) (fslI MsgCourseFilterSearch)
      , muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt boolField (fslI MsgCourseFilterRegistered))
      ]
    , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
    , dbtParams = def
    , dbtIdent = "courses" :: Text
    }

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)) -> -- getTermCourseListR tid
        redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc.

getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html
getTermSchoolCourseListR tid ssh = do
  void . runDB $ get404 tid -- Just ensure the term exists
  School{schoolName=school} <- runDB $ get404 ssh -- Just ensure the term exists
  muid <- maybeAuthId
  let colonnade = widgetColonnade $ mconcat
        [ dbRow
        , colCShort
        , colDescription
        , colRegFrom
        , colRegTo
        , colMembers
        , maybe mempty (const colRegistered) muid
        ]
      whereClause (course, _, _) =
              course E.^. CourseTerm   E.==. E.val tid
        E.&&. course E.^. CourseSchool E.==. E.val ssh
      validator = def
        & defaultSorting [SortAscBy "cshort"]
  coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
  defaultLayout $ do
    setTitleI $ MsgTermSchoolCourseListTitle tid school
    $(widgetFile "courses")


getTermCourseListR :: TermId -> Handler Html
getTermCourseListR tid = do
  void . runDB $ get404 tid -- Just ensure the term exists
  muid <- maybeAuthId
  let colonnade = widgetColonnade $ mconcat
        [ dbRow
        , colCShort
        , colDescription
        , colSchoolShort
        , colRegFrom
        , colRegTo
        , colMembers
        , maybe mempty (const colRegistered) muid
        ]
      whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid
      validator = def
        & defaultSorting [SortAscBy "cshort"]
  coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
  defaultLayout $ do
    setTitleI . MsgTermCourseListTitle $ tid
    $(widgetFile "courses")

getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do
  mbAid <- maybeAuthId
  (course,schoolName,participants,registration,defSFid,lecturers) <- runDB . maybeT notFound $ do
    [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
       <- 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.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.sub_select . E.from $ \part -> do
                  E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
                  return ( E.countRows :: E.SqlExpr (E.Value Int64))
            return (course,school E.^. SchoolName, numParticipants, participant)
    defSFid <- ifMaybeM mbAid Nothing $ \uid -> lift $ selectFirst [StudyFeaturesUser ==. uid, StudyFeaturesType ==. FieldPrimary, StudyFeaturesValid ==. True] [Desc StudyFeaturesUpdated, Desc StudyFeaturesDegree, Desc StudyFeaturesField] -- sorting by degree & field is an heuristic only, but this is okay for a default suggestion
    lecturers <- 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 (user E.^. UserDisplayName, user E.^. UserSurname, user E.^. UserEmail)
    return (course,schoolName,participants,registration,entityKey <$> defSFid,lecturers)

  mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom    course
  mRegTo   <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo      course
  mDereg   <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
  mRegAt   <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
  (regWidget, regEnctype) <- generateFormPost $ registerForm mbAid registration defSFid $ courseRegisterSecret course
  registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
  siteLayout (toWgt $ courseName course) $ do
    setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
    $(widgetFile "course")

-- | Registration button with maybe a userid if logged in
-- , maybe existing features if already registered
-- , maybe some default study features
-- , maybe a course secret
registerForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool)
-- unfinished WIP: must take study features if registred and show as mforced field
registerForm loggedin participant defSFid msecret = identForm FIDcourseRegister $ \extra -> do
    -- secret fields
    (msecretRes', msecretView) <- case msecret of
      (Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
      _ -> return (Nothing,Nothing)
    -- study features
    (msfRes', msfView) <- case loggedin of
      Nothing -> return (Nothing,Nothing)
      Just _  -> bimap Just Just <$> case participant of
        Just CourseParticipant{courseParticipantField=Just sfid}
                -> mforced (studyFeaturesPrimaryFieldFor [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid)
        _other  -> mreq    (studyFeaturesPrimaryFieldFor [ ]    loggedin) (fslI MsgCourseStudyFeature
                                                                 & setTooltip  MsgCourseStudyFeatureTooltip) (Just defSFid)
    -- button de-/register
    (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister isRegistered) "buttonField ignores settings anyway" Nothing

    let widget = $(widgetFile "widgets/register-form/register-form")
    let msecretRes | Just res <- msecretRes' = Just <$> res
                   | otherwise               = FormSuccess Nothing
    let msfRes     | Just res <- msfRes'     = res
                   | otherwise               = FormSuccess Nothing
    -- checks that correct button was pressed, and ignores result of btnRes
    let formRes = (,) <$ btnRes <*> msfRes <*> ((==msecret) <$> msecretRes)
    return (formRes, widget)
  where
    isRegistered = isJust participant


postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCRegisterR tid ssh csh = do
  aid <- requireAuthId
  (cid, course, registration) <- runDB $ do
      (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
      registration <- getBy (UniqueParticipant aid cid)
      return (cid, course, entityVal <$> registration)
  let isRegistered  = isJust registration
  ((regResult,_), _) <- runFormPost $ registerForm (Just aid) registration Nothing $ courseRegisterSecret course
  formResult regResult $ \(mbSfId,codeOk) -> if
      | isRegistered -> do
          runDB $ deleteBy $ UniqueParticipant aid cid
          addMessageI Info MsgCourseDeregisterOk
      | codeOk -> do
          actTime <- liftIO getCurrentTime
          regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId
          when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
      | otherwise -> addMessageI Warning MsgCourseSecretWrong
  -- addMessage Info $ toHtml $ show regResult -- For debugging only
  redirect $ CourseR tid ssh csh CShowR


getCourseNewR :: Handler Html -- call via toTextUrl
getCourseNewR = do
  uid <- requireAuthId
  params <- runInputGetResult $ (,,)    --TODO: change to AForm, which is used in Course-Copy-Button
            <$> iopt termNewField "tid"
            <*> iopt ciField      "ssh"
            <*> iopt ciField      "csh"


  let noTemplateAction = courseEditHandler Nothing
  case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty makeCourseForm any more!
    FormMissing      -> noTemplateAction
    FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >>
                        noTemplateAction
    FormSuccess (Nothing, Nothing, Nothing) -> noTemplateAction
    FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
      oldCourses <- runDB $
        E.select $ E.from $ \course -> do
          whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm       E.==. E.val tid
          whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool     E.==. E.val ssh
          whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand  E.==. E.val csh
          let lecturersCourse =
                E.exists $ E.from $ \lecturer ->
                  E.where_ $ lecturer E.^. LecturerUser   E.==. E.val uid
                      E.&&.  lecturer E.^. LecturerCourse E.==. course E.^. CourseId
          let lecturersSchool =
                E.exists $ E.from $ \user ->
                  E.where_ $ user E.^. UserLecturerUser   E.==. E.val uid
                      E.&&.  user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
          let courseCreated c =
                E.sub_select . E.from $ \edit -> do      -- oldest edit must be creation
                  E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
                  return $ E.min_ $ edit E.^. CourseEditTime
          E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
                    , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
                    , E.desc $ courseCreated course]                                     -- most recent created course
          E.limit 1
          return course
      template <- case listToMaybe oldCourses of
        (Just oldTemplate) ->
            let newTemplate = courseToForm oldTemplate in
            return $ Just $ newTemplate
                { cfCourseId   = Nothing
                , cfTerm       = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
                , cfRegFrom    = Nothing
                , cfRegTo      = Nothing
                , cfDeRegUntil = Nothing
                }
        Nothing -> do
            (tidOk,sshOk,cshOk) <- runDB $ (,,)
                <$> ifMaybeM mbTid True existsKey
                <*> ifMaybeM mbSsh True existsKey
                <*> ifMaybeM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
            unless tidOk $ addMessageI Warning $ MsgNoSuchTerm   $ fromJust mbTid -- safe, since tidOk==True otherwise
            unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
            unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
            when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
            return Nothing
      courseEditHandler template

postCourseNewR :: Handler Html
postCourseNewR = courseEditHandler Nothing -- Note: Nothing is safe here, since we will create a new course.

getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCEditR  = pgCEditR
postCEditR = pgCEditR

pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
pgCEditR tid ssh csh = do
  course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
  -- IMPORTANT: both GET and POST Handler must use the same template,
  --    since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
  courseEditHandler $ courseToForm <$> course


getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCDeleteR = postCDeleteR
postCDeleteR tid ssh csh = do
  Entity cId _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
  deleteR $ (courseDeleteRoute $ Set.singleton cId)
    { drAbort = SomeRoute $ CourseR tid ssh csh CShowR
    , drSuccess = SomeRoute $ TermSchoolCourseListR tid ssh
    }


-- | Course Creation and Editing
-- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing),
-- |            since an edit is identified via cfCourseId which is not contained in the received form data for security reasons!
courseEditHandler :: Maybe CourseForm -> Handler Html
courseEditHandler mbCourseForm = do
    aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
    ((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm mbCourseForm
    case result of
      (FormSuccess res@CourseForm
        { cfCourseId = Nothing
        , cfShort    = csh
        , cfSchool   = ssh
        , cfTerm     = tid
        }) -> do -- create new course
          now <- liftIO getCurrentTime
          insertOkay <- runDB $ insertUnique Course
            { courseName            = cfName     res
            , courseDescription     = cfDesc     res
            , courseLinkExternal    = cfLink     res
            , courseShorthand       = cfShort    res
            , courseTerm            = cfTerm     res
            , courseSchool          = cfSchool   res
            , courseCapacity        = cfCapacity res
            , courseRegisterSecret  = cfSecret   res
            , courseMaterialFree    = cfMatFree  res
            , courseRegisterFrom    = cfRegFrom  res
            , courseRegisterTo      = cfRegTo    res
            , courseDeregisterUntil = cfDeRegUntil res
            }
          case insertOkay of
            (Just cid) -> do
              runDB $ do
                insert_ $ CourseEdit aid now cid
                insert_ $ Lecturer aid cid
              addMessageI Info $ MsgCourseNewOk tid ssh csh
              redirect $ TermCourseListR tid
            Nothing ->
              addMessageI Warning $ MsgCourseNewDupShort tid ssh csh

      (FormSuccess res@CourseForm
        { cfCourseId = Just cid
        , cfShort    = csh
        , cfSchool   = ssh
        , cfTerm     = tid
        }) -> do -- edit existing course
          now <- liftIO getCurrentTime
          -- addMessage "debug" [shamlet| #{show res}|]
          success <- runDB $ do
            old <- get cid
            case old of
              Nothing -> addMessageI Error MsgInvalidInput $> False
              (Just _) -> do
                updOkay <- myReplaceUnique cid Course
                  { courseName            = cfName       res
                  , courseDescription     = cfDesc       res
                  , courseLinkExternal    = cfLink       res
                  , courseShorthand       = cfShort      res
                  , courseTerm            = cfTerm       res -- dangerous
                  , courseSchool          = cfSchool     res
                  , courseCapacity        = cfCapacity   res
                  , courseRegisterSecret  = cfSecret     res
                  , courseMaterialFree    = cfMatFree    res
                  , courseRegisterFrom    = cfRegFrom    res
                  , courseRegisterTo      = cfRegTo      res
                  , courseDeregisterUntil = cfDeRegUntil res
                  }
                case updOkay of
                  (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
                  Nothing  -> do
                    insert_ $ CourseEdit aid now cid
                    addMessageI Success $ MsgCourseEditOk tid ssh csh
                    return True
          when success $ redirect $ CourseR tid ssh csh CShowR

      (FormFailure _) -> addMessageI Warning MsgInvalidInput
      FormMissing -> return ()
    actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
    defaultLayout $ do
      setTitleI MsgCourseEditTitle
      $(widgetFile "formPage")


data CourseForm = CourseForm
        { cfCourseId   :: Maybe CourseId
        , cfName       :: CourseName
        , cfDesc       :: Maybe Html
        , cfLink       :: Maybe Text
        , cfShort      :: CourseShorthand
        , cfTerm       :: TermId
        , cfSchool     :: SchoolId
        , cfCapacity   :: Maybe Int64
        , cfSecret     :: Maybe Text
        , cfMatFree    :: Bool
        , cfRegFrom    :: Maybe UTCTime
        , cfRegTo      :: Maybe UTCTime
        , cfDeRegUntil :: Maybe UTCTime
        }

courseToForm :: Entity Course -> CourseForm
courseToForm (Entity cid Course{..}) = CourseForm
    { cfCourseId   = Just cid
    , cfName       = courseName
    , cfDesc       = courseDescription
    , cfLink       = courseLinkExternal
    , cfShort      = courseShorthand
    , cfTerm       = courseTerm
    , cfSchool     = courseSchool
    , cfCapacity   = courseCapacity
    , cfSecret     = courseRegisterSecret
    , cfMatFree    = courseMaterialFree
    , cfRegFrom    = courseRegisterFrom
    , cfRegTo      = courseRegisterTo
    , cfDeRegUntil = courseDeregisterUntil
    }

makeCourseForm :: Maybe CourseForm -> Form CourseForm
makeCourseForm template = identForm FIDcourse $ \html -> do
    -- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs
    -- let editCid = cfCourseId =<< template -- possible start for refactoring

    mr <- liftHandlerT getMessageRender -- needed for translation of placeholders

    userSchools <- liftHandlerT . runDB $ do
      userId <- liftHandlerT requireAuthId
      (fmap concat . sequence)
        [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
        , map (userAdminSchool    . entityVal) <$> selectList [UserAdminUser    ==. userId] []
        ]

    termsField <- case template of
          -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
          (Just cform)  | (Just cid) <- cfCourseId cform -> liftHandlerT $ do -- edit existing course
              _courseOld@Course{..} <- runDB $ get404 cid
              mayEditTerm <- isAuthorized TermEditR True
              mayDelete   <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
              return $ if
                | (mayEditTerm == Authorized) || (mayDelete == Authorized) -> termsAllowedField
                | otherwise ->  termsSetField [cfTerm cform]
          _allOtherCases -> return termsAllowedField

    (newRegFrom,newRegTo,newDeRegUntil) <- case template of
        (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
        _allIOtherCases -> do
            mbLastTerm <- liftHandlerT $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
            return ( (Just . toMidnight     . termStart . entityVal) <$> mbLastTerm
                   , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm
                   , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm )

    (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
      <$> pure (cfCourseId =<< template)
      <*> areq ciField (fslI MsgCourseName)                             (cfName       <$> template)
      <*> aopt htmlField (fslpI MsgCourseDescription "Bitte mindestens die Modulbeschreibung angeben"
                         & setTooltip MsgCourseDescriptionTip)          (cfDesc       <$> template)
      <*> aopt urlField  (fslpI MsgCourseHomepageExternal "Optionale externe URL")
                                                                        (cfLink       <$> template)
      <*> areq ciField (fslI MsgCourseShorthand
            -- & addAttr "disabled" "disabled"
            & setTooltip MsgCourseShorthandUnique)                      (cfShort      <$> template)
      <*> areq termsField                     (fslI MsgCourseSemester)  (cfTerm       <$> template)
      <*> areq (schoolFieldFor userSchools)   (fslI MsgCourseSchool)    (cfSchool     <$> template)
      <*> aopt (natFieldI MsgCourseCapacity)  (fslI MsgCourseCapacity
            & setTooltip MsgCourseCapacityTip)                          (cfCapacity   <$> template)
      <*> aopt textField      (fslpI MsgCourseSecret (mr MsgCourseSecretFormat)
            & setTooltip MsgCourseSecretTip)                            (cfSecret     <$> template)
      <*> areq checkBoxField  (fslI  MsgMaterialFree)                   (cfMatFree    <$> template)
      <*> aopt utcTimeField   (fslpI MsgRegisterFrom (mr MsgDate)
            & setTooltip MsgCourseRegisterFromTip)                      (deepAlt (cfRegFrom    <$> template) newRegFrom)
      <*> aopt utcTimeField   (fslpI MsgRegisterTo   (mr MsgDate)
            & setTooltip MsgCourseRegisterToTip)                        (deepAlt (cfRegTo      <$> template) newRegTo)
      <*> aopt utcTimeField   (fslpI MsgDeRegUntil   (mr MsgDate)
            & setTooltip MsgCourseDeregisterUntilTip)                   (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
      <*  submitButton
    return $ case result of
      FormSuccess courseResult
        | errorMsgs <- validateCourse courseResult
        , not $ null errorMsgs ->
          (FormFailure errorMsgs,
                [whamlet|
                  <div class="alert alert-danger">
                    <div class="alert__content">
                      <h4> Fehler:
                      <ul>
                        $forall errmsg <- errorMsgs
                          <li> #{errmsg}
                  ^{widget}
                |]
              )
      _ -> (result, widget)


validateCourse :: CourseForm -> [Text]
validateCourse CourseForm{..} =
  [ msg | (False, msg) <-
    [
      ( NTop cfRegFrom <= NTop cfRegTo
      , "Ende des Anmeldezeitraums muss nach dem Anfang liegen"
      )
    ,
      ( NTop cfRegFrom <= NTop cfDeRegUntil
      , "Ende des Abmeldezeitraums muss nach dem Anfang liegen"
      )
--    No starting date is okay: effective immediately
--       ( cfHasReg <= (isNothing cfRegFrom)
--       , "Beginn der Anmeldung angeben oder Anmeldungen deaktivieren"
--       )
--     ,
  ] ]



--------------------
-- CourseUserTable

type UserTableExpr   = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant))
        `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
        `E.LeftOuterJoin`
        (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin`E.SqlExpr (Maybe (Entity StudyTerms)))
type UserTableData   = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId, (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms))

forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a)
forceUserTableType = id

userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User)
                                                          , E.SqlExpr (E.Value UTCTime)
                                                          , E.SqlExpr (E.Value (Maybe (Key CourseUserNote)))
                                                          , StudyFeaturesDescription')

userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures) = do
  -- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis
  features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures
  E.on $ E.just (participant E.^. CourseParticipantUser) E.==. note E.?. CourseUserNoteUser
  E.on $         participant E.^. CourseParticipantUser  E.==. user E.^. UserId
  E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
  return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, features)


instance HasEntity UserTableData User where
  hasEntity = _dbrOutput . _1

instance HasUser UserTableData where
  -- hasUser = _entityVal
  hasUser = _dbrOutput . _1 . _entityVal

_userTableRegistration :: Lens' UserTableData UTCTime
_userTableRegistration = _dbrOutput . _2

_userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
_userTableNote = _dbrOutput . _3

_userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
_userTableFeatures = _dbrOutput . _4

_rowUserSemester :: Traversal' UserTableData Int
_rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester


-- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions)
queryUser :: UserTableExpr -> E.SqlExpr (Entity User)
queryUser ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user

-- queryUserName :: UserTableExpr -> E.SqlExpr (E.Value Text)
-- queryUserName ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserDisplayName

-- queryUserDisplayName :: UserTableExpr -> E.SqlExpr (E.Value Text)
-- queryUserDisplayName ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserDisplayName

queryUserFeatures :: UserTableExpr -> (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin`E.SqlExpr (Maybe (Entity StudyTerms)))
queryUserFeatures ((_user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` studyFeatures) = studyFeatures

queryUserSemester :: UserTableExpr -> E.SqlExpr (E.Value (Maybe Int)) -- (E.Value (Maybe Int))
queryUserSemester = aux . queryUserFeatures
  where aux (features `E.InnerJoin` _degree `E.InnerJoin` _terms)
          = features E.?. StudyFeaturesSemester

-- Deprecated in favour of newer implementation
queryUserSemester' :: UserTableExpr -> E.SqlExpr (E.Value (Maybe Int)) -- (E.Value (Maybe Int))
queryUserSemester' ((_user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` (features `E.InnerJoin` _degree `E.InnerJoin` _terms) )
    = features E.?. StudyFeaturesSemester

colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
colUserComment tid ssh csh =
    sortable (Just "course-user-note") (i18nCell MsgCourseUserNote)
      $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey,_) } ->
        maybeEmpty mbNoteKey $ const $
          anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True)
  where
    courseLink = CourseR tid ssh csh . CUserR

colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserSemester = sortable (Just "course-user-semesternr") (i18nCell MsgStudyFeatureAge) $
    foldMap numCell . preview _rowUserSemester

colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserField = sortable (Just "course-user-field") (i18nCell MsgCourseStudyFeature) $
    foldMap htmlCell . view (_userTableFeatures . _3)

colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserFieldShort = sortable (Just "course-user-field") (i18nCell MsgCourseStudyFeature) $
    foldMap (htmlCell . shortStudyTerms) . view (_userTableFeatures . _3)

colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserDegree = sortable (Just "course-user-degree") (i18nCell MsgStudyFeatureDegree) $
    foldMap htmlCell . preview (_userTableFeatures . _2 . _Just)

colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserDegreeShort = sortable (Just "course-user-degree") (i18nCell MsgStudyFeatureDegree) $
    foldMap (htmlCell . shortStudyDegree) . preview (_userTableFeatures . _2 . _Just)

makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget
makeCourseUserTable cid colChoices psValidator =
  -- -- psValidator has default sorting and filtering
  let dbtIdent     = "courseUsers" :: Text
      dbtStyle     = def
      dbtSQLQuery  = userTableQuery cid
      dbtRowKey ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserId
      dbtProj      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
      dbtColonnade = colChoices
      dbtSorting   = Map.fromList
        [ sortUserName        queryUser
        , sortUserDisplayName queryUser
        , sortUserMatriclenr  queryUser
        , ( "course-user-semesternr", SortColumn queryUserSemester) -- $ -- preview (_userTableFeatures . _1 . _Just . _studyFeaturesSemester))
        -- TODO
        ]
      dbtFilter    = Map.fromList
        [ filterUserName queryUser
        , ( "course-user-semesternr", FilterColumn $ mkInFilter queryUserSemester)
        -- TODO
        ]
      dbtFilterUI  = mempty -- TODO
      dbtParams    = def
  in dbTableWidget' psValidator DBTable{..}


getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCUsersR tid ssh csh = do
  Entity cid course <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
  let heading = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
      colChoices  = mconcat
        [ colUserNameLink (CourseR tid ssh csh . CUserR)
        , colUserEmail
        , colUserMatriclenr
        , colUserDegreeShort
        , colUserFieldShort
        , colUserSemester
        , sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration)
        , colUserComment tid ssh csh
        ]
      psValidator = def & defaultSortingByName
  tableWidget <- runDB $ makeCourseUserTable cid colChoices psValidator
  siteLayout heading $ do
    setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
    -- TODO: create hamlet wrapper
    tableWidget



getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
getCUserR _tid _ssh _csh uCId = do
  -- Has authorization checks (OR):
  --
  --   - User is current member of course
  --   - User has submitted in course
  --   - User is member of registered group for course
  --   - User is member of a tutorial for course
  --   - User is corrector for course
  --   - User is a tutor for course
  --   - User is a lecturer for course
  uid <- decrypt uCId
  User{..} <- runDB $ get404 uid
  -- USE src/utils/Form.formResult
  defaultLayout -- TODO
    [whamlet|
      <p>^{nameWidget userDisplayName userSurname}
    |]

getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCHiWisR = error "CHiWisR: Not implemented"

getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-- NOTE: The route getNotesR is abused for correctorORlecturer access rights!
getCNotesR = error "CNotesR: Not implemented"
postCNotesR = error "CNotesR: Not implemented"