{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}

module Handler.Course where

import Import hiding (catMaybes)

import Control.Lens
import Utils.Lens
import Utils.TH
-- import Utils.DB
import Handler.Utils
import Handler.Utils.Table.Cells

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

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

import qualified Data.CaseInsensitive as CI


import Colonnade hiding (fromMaybe,bool)
-- import Yesod.Colonnade

import qualified Database.Esqueleto as E

import qualified Data.UUID.Cryptographic as UUID

-- 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 cid 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 cid 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 cid 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 cid 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 anzeigen" (Right $ toWidget descr)}
                  |]
            )

colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgTerm)
          $ \DBRow{ dbrOutput=(Entity cid 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 cid 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 cid Course{..}, _, _, _) } ->
            cell $ traverse (formatTime SelFormatDateTime) courseRegisterTo >>= maybe mempty toWidget

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

colRegistered :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, 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 -> do
    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 )
                     => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
makeCourseTable whereClause colChoices psValidator = do
  muid <- 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)
  dbTable psValidator $ DBTable
    { dbtSQLQuery
    , 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)
          )
        ]
    , dbtStyle = def
    , dbtIdent = "courses" :: Text
    }

getCourseListR :: Handler Html
getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
  muid <- maybeAuthId
  let colonnade = widgetColonnade $ mconcat
        [ colCourseDescr
        , colCShort
        , colTerm
        , maybe mempty (const colRegistered) muid
        , colSchool
        ]
      whereClause = const $ E.val True
      validator = def
        & defaultSorting [("course", SortAsc), ("term", SortDesc)]
  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
  defaultLayout $ do
    setTitleI MsgCourseListTitle
    [whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO
    $(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 [("cshort", SortAsc)]
  ((), coursesTable) <- 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 [("cshort", SortAsc)]
  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
  defaultLayout $ do
    setTitleI . MsgTermCourseListTitle $ tid
    $(widgetFile "courses")

getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do
  mbAid <- maybeAuthId
  (courseEnt,(schoolMB,participants,registered),lecturers) <- runDB $ do
      courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
      dependent <- (,,)
          <$> get (courseSchool course)               -- join -- just fetch full school name here
          <*> count [CourseParticipantCourse ==. cid] -- join
          <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
                Nothing -> return False
                (Just aid) -> do  regL <- getBy (UniqueParticipant aid cid)
                                  return $ isJust regL)
      lecturers <- 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 $ (courseEnt,dependent,E.unValue <$> lecturers)
  let course = entityVal courseEnt
  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
  registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
  mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
  mRegTo   <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
  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


getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html
getCourseNewTemplateR mbTid mbSsh mbCsh =
  redirect (CourseNewR, catMaybes [ ("tid",).termToText.unTermKey    <$> mbTid
                                  , ("ssh",).CI.original.unSchoolKey <$> mbSsh
                                  , ("csh",).CI.original             <$> mbCsh
                                  ])

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
      uid <- requireAuthId
      oldCourses <- runDB $ do
        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 -> do
                  E.where_ $ lecturer E.^. LecturerUser   E.==. E.val uid
                      E.&&.  lecturer E.^. LecturerCourse E.==. course E.^. CourseId
          let lecturersSchool =
                E.exists $ E.from $ \user -> do
                  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 :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCDeleteR = error "TODO: implement getCDeleteR"
postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCDeleteR = error "TODO: implement getCDeleteR"
{- TODO
        | False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler
        , Just cid <- cfCourseId res -> do
            runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
            let cti = toPathPiece $ cfTerm res
            addMessage Info [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
            redirect $ TermCourseListR $ cfTerm res
-}


-- | 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
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 oldCourse) -> do
                updOkay <- myReplaceUnique cid (  -- replaceUnique requires Eq Course, which we cannot have
                    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 tid ssh csh = undefined -- TODO


getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
getCUserR tid ssh csh uuid = do
  uid <- decrypt uuid
  User{..} <- runDB $ get404 uid
  defaultLayout $
    [whamlet|
      <h1>TODO
      <h2>Lecturer's Page for User ^{nameWidget userDisplayName userSurname}
    |]

getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCHiWisR tid ssh csh = undefined -- TODO