module Handler.Course where

import Import

import Utils.Lens
-- import Utils.DB
import Handler.Utils
import Handler.Utils.Table.Cells
import Handler.Utils.Course
import Handler.Utils.Delete

-- 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 (i18nCell MsgCourseDescription)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
            case courseDescription of
              Nothing      -> mempty
              (Just descr) -> cell $ modal "Beschreibung" (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 timeCell 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 timeCell courseRegisterTo

colParticipants :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colParticipants = sortable (Just "participants") (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)
        , ( "participants",  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
        [ colCourseDescr
        , colSchoolShort
        , colTerm
        , colCShort
        , maybe mempty (const colRegistered) muid

        ]
      whereClause = const $ E.val True
      validator = def
        & defaultSorting [SortAscBy "course", SortDescBy "term"]
  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
        , colCShortDescr
        , colRegFrom
        , colRegTo
        , colParticipants
        , 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
        , colCShortDescr
        , colSchoolShort
        , colRegFrom
        , colRegTo
        , colParticipants
        , 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,registered,lecturers) <- runDB . maybeT notFound $ do
    [(E.Entity cid course, E.Value schoolName, E.Value participants, E.Value registered)]
       <- 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
            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 E.?. CourseParticipantRegistration)
    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
      return $ user E.^. UserDisplayName
    return (course,schoolName,participants,registered,map E.unValue lecturers)
  mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom    course
  mRegTo   <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo      course
  mDereg   <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
  mRegAt   <- traverse (formatTime SelFormatDateTime)   registered
  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course
  registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
  defaultLayout $ do
    setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
    $(widgetFile "course")


registerForm :: Bool -> Maybe Text -> Form Bool
registerForm registered msecret extra = do
  (msecretRes', msecretView) <- case msecret of
    (Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
    _ -> return (Nothing,Nothing)
  (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
  let widget = $(widgetFile "widgets/registerForm")
  let msecretRes | Just res <- msecretRes' = Just <$> res
                 | otherwise               = FormSuccess Nothing
  return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes


postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCRegisterR tid ssh csh = do
  aid <- requireAuthId
  (cid, course, registered) <- runDB $ do
      (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
      registered <- isJust <$> getBy (UniqueParticipant aid cid)
      return (cid, course, registered)
  ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
  case regResult of
    (FormSuccess codeOk)
      | registered -> do
          runDB $ deleteBy $ UniqueParticipant aid cid
          addMessageI Info MsgCourseDeregisterOk
      | codeOk -> do
          actTime <- liftIO getCurrentTime
          regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
          when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
      | otherwise -> addMessageI Warning MsgCourseSecretWrong
    _other -> return () -- TODO check this!
  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 True Nothing
  case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty newCourseForm any more!
    FormMissing      -> noTemplateAction
    FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >>
                        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 True template

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

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

pgCEditR :: Bool -> TermId -> SchoolId -> CourseShorthand -> Handler Html
pgCEditR isGetReq 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 isGetReq $ 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 :: Bool -> Maybe CourseForm -> Handler Html -- FIXME: _isGet is not used
courseEditHandler _isGet mbCourseForm = do
    aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
    ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm 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
    }

newCourseForm :: Maybe CourseForm -> Form CourseForm
newCourseForm template = identForm FIDcourse $ \html -> do
    userSchools <- liftHandlerT . runDB $ do
      userId <- liftHandlerT requireAuthId
      (fmap concat . sequence)
        [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
        , map (userAdminSchool    . entityVal) <$> selectList [UserAdminUser    ==. userId] []
        ]

    termsField <- liftHandlerT $ 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 -> 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
    (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
      <$> pure (cfCourseId =<< template)
      <*> areq ciField (fslI MsgCourseName)          (cfName     <$> template)
      <*> aopt htmlField (fslI MsgCourseDescription
                         & setTooltip MsgCourseDescriptionTip)   (cfDesc     <$> template)
      <*> aopt urlField  (fslI MsgCourseHomepage)                (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 (natField "Kapazität")       (fslI MsgCourseCapacity
            & setTooltip MsgCourseCapacityTip)                          (cfCapacity <$> template)
      <*> aopt textField      (fslpI MsgCourseSecret "beliebige Zeichenkette"
            & setTooltip MsgCourseSecretTip)                            (cfSecret   <$> template)
      <*> areq checkBoxField  (fslI  MsgMaterialFree)                   (cfMatFree  <$> template)
      <*> aopt utcTimeField   (fslpI MsgRegisterFrom "Datum"
            & setTooltip MsgCourseRegisterFromTip)                      (cfRegFrom  <$> template)
      <*> aopt utcTimeField   (fslpI MsgRegisterTo   "Datum"
            & setTooltip MsgCourseRegisterToTip)                        (cfRegTo    <$> template)
      <*> aopt utcTimeField   (fslpI MsgDeRegUntil   "Datum"
            & setTooltip MsgCourseDeregisterUntilTip)                   (cfDeRegUntil <$> template)
      <*  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"
--       )
--     ,
  ] ]



getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCUsersR = error "CUsersR: Not implemented"


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"
