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

module Handler.Exam where

import Import

import Handler.Utils
import Handler.Utils.Exam
import Handler.Utils.Invitations
import Handler.Utils.Table.Columns
import Handler.Utils.Table.Cells
import Handler.Utils.Csv
import Jobs.Queue

import Utils.Lens hiding (parts)
  
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH

import Data.Map ((!), (!?))
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Data.Text as Text
import qualified Data.Text.Lens as Text

import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet)
import Text.Blaze.Html.Renderer.String (renderHtml)

import qualified Data.CaseInsensitive as CI

import qualified Control.Monad.State.Class as State
import Control.Arrow (Kleisli(..))

import qualified Data.Csv as Csv

import qualified Data.Conduit.List as C

import Numeric.Lens (integral)

import Database.Persist.Sql (deleteWhereCount, updateWhereCount)



-- Dedicated ExamRegistrationButton
data ButtonExamRegister = BtnExamRegister | BtnExamDeregister
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonExamRegister
instance Finite ButtonExamRegister
nullaryPathPiece ''ButtonExamRegister $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonExamRegister id
instance Button UniWorX ButtonExamRegister where
  btnClasses BtnExamRegister   = [BCIsButton, BCPrimary]
  btnClasses BtnExamDeregister = [BCIsButton, BCDanger]

  btnLabel  BtnExamRegister   = [whamlet|#{iconExamRegister True}  _{MsgBtnExamRegister}|]
  btnLabel  BtnExamDeregister = [whamlet|#{iconExamRegister False} _{MsgBtnExamDeregister}|]



getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCExamListR tid ssh csh = do
  Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
  now <- liftIO getCurrentTime
  mayCreate <- hasWriteAccessTo $ CourseR tid ssh csh CExamNewR

  let
    examDBTable = DBTable{..}
      where
        dbtSQLQuery exam = do
          E.where_ $ exam E.^. ExamCourse E.==. E.val cid
          return exam
        dbtRowKey = (E.^. ExamId)
        dbtProj x@DBRow{ dbrOutput = Entity _ Exam{..} } = do
          guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
          return x
        dbtColonnade = dbColonnade . mconcat $ catMaybes
          [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) examName
          , (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
          , Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
          , Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
          , Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
          ]
        dbtSorting = Map.fromList
          [ ("name", SortColumn $ \exam -> exam E.^. ExamName )
          , ("time", SortColumn $ \exam -> exam E.^. ExamStart )
          , ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
          , ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
          , ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
          ]
        dbtFilter = Map.empty
        dbtFilterUI = const mempty
        dbtStyle = def
        dbtParams = def
        dbtIdent :: Text
        dbtIdent = "exams"
        dbtCsvEncode = noCsvEncode
        dbtCsvDecode = Nothing

    examDBTableValidator = def
      & defaultSorting [SortAscBy "time"]
  ((), examTable) <- runDB $ dbTable examDBTableValidator examDBTable

  siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do
    setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading
    $(widgetFile "exam-list")


instance IsInvitableJunction ExamCorrector where
  type InvitationFor ExamCorrector = Exam
  data InvitableJunction ExamCorrector = JunctionExamCorrector
    deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationDBData ExamCorrector = InvDBDataExamCorrector
    deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationTokenData ExamCorrector = InvTokenDataExamCorrector
    deriving (Eq, Ord, Read, Show, Generic, Typeable)

  _InvitableJunction = iso
    (\ExamCorrector{..} -> (examCorrectorUser, examCorrectorExam, JunctionExamCorrector))
    (\(examCorrectorUser, examCorrectorExam, JunctionExamCorrector) -> ExamCorrector{..})

instance ToJSON (InvitableJunction ExamCorrector) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction ExamCorrector) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }

instance ToJSON (InvitationDBData ExamCorrector) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationDBData ExamCorrector) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }

instance ToJSON (InvitationTokenData ExamCorrector) where
  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationTokenData ExamCorrector) where
  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }

examCorrectorInvitationConfig :: InvitationConfig ExamCorrector
examCorrectorInvitationConfig = InvitationConfig{..}
  where
    invitationRoute (Entity _ Exam{..}) _ = do
      Course{..} <- get404 examCourse
      return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR
    invitationResolveFor = do
      Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute
      fetchExamId tid csh ssh examn
    invitationSubject Exam{..} _ = do
      Course{..} <- get404 examCourse
      return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName
    invitationHeading Exam{..} _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
    invitationTokenConfig _ _ = do
      itAuthority <- liftHandlerT requireAuthId
      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
    invitationRestriction _ _ = return Authorized
    invitationForm _ _ _ = pure JunctionExamCorrector
    invitationSuccessMsg Exam{..} _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName
    invitationUltDest Exam{..} _ = do
      Course{..} <- get404 examCourse
      return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CExamListR

getECInviteR, postECInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getECInviteR = postECInviteR
postECInviteR = invitationR examCorrectorInvitationConfig


data ExamForm = ExamForm
  { efName :: ExamName
  , efDescription :: Maybe Html
  , efStart :: Maybe UTCTime
  , efEnd :: Maybe UTCTime
  , efVisibleFrom :: Maybe UTCTime
  , efRegisterFrom :: Maybe UTCTime
  , efRegisterTo :: Maybe UTCTime
  , efDeregisterUntil :: Maybe UTCTime
  , efPublishOccurrenceAssignments :: Maybe UTCTime
  , efFinished :: Maybe UTCTime
  , efClosed :: Maybe UTCTime
  , efOccurrences :: Set ExamOccurrenceForm
  , efShowGrades :: Bool
  , efPublicStatistics :: Bool
  , efGradingRule :: ExamGradingRule
  , efBonusRule :: ExamBonusRule
  , efOccurrenceRule :: ExamOccurrenceRule
  , efCorrectors :: Set (Either UserEmail UserId)
  , efExamParts :: Set ExamPartForm
  }

data ExamOccurrenceForm = ExamOccurrenceForm
  { eofId :: Maybe CryptoUUIDExamOccurrence
  , eofName :: ExamOccurrenceName
  , eofRoom :: Text
  , eofCapacity :: Natural
  , eofStart :: UTCTime
  , eofEnd :: Maybe UTCTime
  , eofDescription :: Maybe Html
  } deriving (Read, Show, Eq, Ord, Generic, Typeable)

data ExamPartForm = ExamPartForm
  { epfId :: Maybe CryptoUUIDExamPart
  , epfName :: ExamPartName
  , epfMaxPoints :: Maybe Points
  , epfWeight :: Rational
  } deriving (Read, Show, Eq, Ord, Generic, Typeable)

makeLenses_ ''ExamForm

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''ExamPartForm

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''ExamOccurrenceForm


examForm :: Maybe ExamForm -> Form ExamForm
examForm template html = do
  MsgRenderer mr <- getMsgRenderer

  flip (renderAForm FormStandard) html $ ExamForm
    <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
    <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template))
    <*  aformSection MsgExamFormTimes
    <*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template)
    <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template)
    <*> aopt utcTimeField (fslpI MsgExamVisibleFrom (mr MsgDate) & setTooltip MsgExamVisibleFromTip) (efVisibleFrom <$> template)
    <*> aopt utcTimeField (fslpI MsgExamRegisterFrom (mr MsgDate) & setTooltip MsgExamRegisterFromTip) (efRegisterFrom <$> template)
    <*> aopt utcTimeField (fslpI MsgExamRegisterTo (mr MsgDate)) (efRegisterTo <$> template)
    <*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template)
    <*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template)
    <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template)
    <*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template)
    <*  aformSection MsgExamFormOccurrences
    <*> examOccurrenceForm (efOccurrences <$> template)
    <*  aformSection MsgExamFormAutomaticFunctions
    <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (Just . efShowGrades <$> template))
    <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template))
    <*> examGradingRuleForm (efGradingRule <$> template)
    <*> examBonusRuleForm (efBonusRule <$> template)
    <*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
    <*  aformSection MsgExamFormCorrection
    <*> examCorrectorsForm (efCorrectors <$> template)
    <*  aformSection MsgExamFormParts
    <*> examPartsForm (efExamParts <$> template)

examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId))
examCorrectorsForm mPrev = wFormToAForm $ do
  MsgRenderer mr <- getMsgRenderer
  Just currentRoute <- getCurrentRoute
  uid <- liftHandlerT requireAuthId

  let
    miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
    miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag

    miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
    miAdd' nudge submitView csrf = do
      (addRes, addView) <- mpreq (multiUserField False $ Just corrUserSuggestions) ("" & addName (nudge "email")) Nothing
      let
        addRes'
          | otherwise
          = addRes <&> \newDat oldDat -> if
              | existing <- newDat `Set.intersection` Set.fromList oldDat
              , not $ Set.null existing
                -> FormFailure [mr MsgExamCorrectorAlreadyAdded]
              | otherwise
                -> FormSuccess $ Set.toList newDat
      return (addRes', $(widgetFile "widgets/massinput/examCorrectors/add"))

    corrUserSuggestions :: E.SqlQuery (E.SqlExpr (Entity User))
    corrUserSuggestions = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` exam `E.InnerJoin` corrector `E.InnerJoin` corrUser) -> do
      E.on $ corrUser E.^. UserId E.==. corrector E.^. ExamCorrectorUser
      E.on $ corrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId
      E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
      E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
      E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
      return corrUser


    miCell' :: Either UserEmail UserId -> Widget
    miCell' (Left email) =
      $(widgetFile "widgets/massinput/examCorrectors/cellInvitation")
    miCell' (Right userId) = do
      User{..} <- liftHandlerT . runDB $ get404 userId
      $(widgetFile "widgets/massinput/examCorrectors/cellKnown")

    miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
    miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examCorrectors/layout")

  fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgMassInputTip) False (Set.toList <$> mPrev)

examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
examOccurrenceForm prev = wFormToAForm $ do
  Just currentRoute <- getCurrentRoute
  let
    miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
    miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag

  fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
  where
    examOccurrenceForm' nudge mPrev csrf = do
      (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
      (eofNameRes, eofNameView) <- mpreq ciField ("" & addName (nudge "name")) (eofName <$> mPrev)
      (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "room")) (eofRoom <$> mPrev)
      (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev)
      (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev)
      (eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev)
      (eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev)

      return ( ExamOccurrenceForm
                 <$> eofIdRes
                 <*> eofNameRes
                 <*> eofRoomRes
                 <*> eofCapacityRes
                 <*> eofStartRes
                 <*> eofEndRes
                 <*> (assertM (not . null . renderHtml) <$> eofDescRes)
             , $(widgetFile "widgets/massinput/examRooms/form")
             )

    miAdd' nudge submitView csrf = do
      MsgRenderer mr <- getMsgRenderer
      (res, formWidget) <- examOccurrenceForm' nudge Nothing csrf
      let
        addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
          | newDat `Set.member` oldDat -> FormFailure [mr MsgExamRoomAlreadyExists]
          | otherwise -> FormSuccess $ pure newDat
      return (addRes, $(widgetFile "widgets/massinput/examRooms/add"))
    miCell' nudge dat = examOccurrenceForm' nudge (Just dat)
    miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examRooms/layout")
    miIdent' :: Text
    miIdent' = "exam-occurrences"

examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm)
examPartsForm prev = wFormToAForm $ do
  Just currentRoute <- getCurrentRoute
  let
    miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
    miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag

  fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
  where
    examPartForm' nudge mPrev csrf = do
      (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
      (epfNameRes, epfNameView) <- mpreq ciField ("" & addName (nudge "name")) (epfName <$> mPrev)
      (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev)
      (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1)

      return ( ExamPartForm
                 <$> epfIdRes
                 <*> epfNameRes
                 <*> epfMaxPointsRes
                 <*> epfWeightRes
             , $(widgetFile "widgets/massinput/examParts/form")
             )

    miAdd' nudge submitView csrf = do
      MsgRenderer mr <- getMsgRenderer
      (res, formWidget) <- examPartForm' nudge Nothing csrf
      let
        addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
          | any (((==) `on` epfName) newDat) oldDat -> FormFailure [mr MsgExamPartAlreadyExists]
          | otherwise -> FormSuccess $ pure newDat
      return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
    miCell' nudge dat = examPartForm' nudge (Just dat)
    miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examParts/layout")
    miIdent' :: Text
    miIdent' = "exam-parts"

examFormTemplate :: Entity Exam -> DB ExamForm
examFormTemplate (Entity eId Exam{..}) = do
  parts <- selectList [ ExamPartExam ==. eId ] []
  occurrences <- selectList [ ExamOccurrenceExam ==. eId ] []
  correctors <- selectList [ ExamCorrectorExam ==. eId ] []
  invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId

  parts' <- forM parts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part
  occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ

  return ExamForm
    { efName             = examName
    , efGradingRule      = examGradingRule
    , efBonusRule        = examBonusRule
    , efOccurrenceRule   = examOccurrenceRule
    , efVisibleFrom      = examVisibleFrom
    , efRegisterFrom     = examRegisterFrom
    , efRegisterTo       = examRegisterTo
    , efDeregisterUntil  = examDeregisterUntil
    , efPublishOccurrenceAssignments = examPublishOccurrenceAssignments
    , efStart            = examStart
    , efEnd              = examEnd
    , efFinished         = examFinished
    , efClosed           = examClosed
    , efShowGrades       = examShowGrades
    , efPublicStatistics = examPublicStatistics
    , efDescription      = examDescription
    , efOccurrences      = Set.fromList $ do
        (Just -> eofId, ExamOccurrence{..}) <- occurrences'
        return ExamOccurrenceForm
          { eofId
          , eofName        = examOccurrenceName
          , eofRoom        = examOccurrenceRoom
          , eofCapacity    = examOccurrenceCapacity
          , eofStart       = examOccurrenceStart
          , eofEnd         = examOccurrenceEnd
          , eofDescription = examOccurrenceDescription
          }
    , efExamParts        = Set.fromList $ do
        (Just -> epfId, ExamPart{..}) <- parts'
        return ExamPartForm
          { epfId
          , epfName      = examPartName
          , epfMaxPoints = examPartMaxPoints
          , epfWeight    = examPartWeight
          }
    , efCorrectors       = Set.unions
      [ Set.fromList $ map Left invitations
      , Set.fromList . map Right $ do
          Entity _ ExamCorrector{..} <- correctors
          return examCorrectorUser
      ]
    }

examTemplate :: CourseId -> DB (Maybe ExamForm)
examTemplate cid = runMaybeT $ do
  newCourse <- MaybeT $ get cid

  [(Entity _ oldCourse, Entity _ oldExam)] <- lift . E.select . E.from $ \(course `E.InnerJoin` exam) -> do
    E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
    E.where_ $ (       course E.^. CourseShorthand E.==. E.val (courseShorthand newCourse)
                 E.||. course E.^. CourseName E.==. E.val (courseName newCourse)
               )
         E.&&. course E.^. CourseSchool E.==. E.val (courseSchool newCourse)
    E.where_ . E.not_ . E.exists . E.from $ \exam' -> do
      E.where_ $ exam' E.^. ExamCourse E.==. E.val cid
      E.where_ $ exam E.^. ExamName E.==. exam' E.^. ExamName
    E.where_ . E.not_ . E.isNothing $ exam E.^. ExamVisibleFrom
    E.limit 1
    E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ]
    return (course, exam)

  oldTerm <- MaybeT . get $ courseTerm oldCourse
  newTerm <- MaybeT . get $ courseTerm newCourse

  let
    dateOffset = over _utctDay . addDays $ (diffDays `on` termLectureEnd) newTerm oldTerm

  return ExamForm
    { efName             = examName oldExam
    , efGradingRule      = examGradingRule oldExam
    , efBonusRule        = examBonusRule oldExam
    , efOccurrenceRule   = examOccurrenceRule oldExam
    , efVisibleFrom      = dateOffset <$> examVisibleFrom oldExam
    , efRegisterFrom     = dateOffset <$> examRegisterFrom oldExam
    , efRegisterTo       = dateOffset <$> examRegisterTo oldExam
    , efDeregisterUntil  = dateOffset <$> examDeregisterUntil oldExam
    , efPublishOccurrenceAssignments = dateOffset <$> examPublishOccurrenceAssignments oldExam
    , efStart            = dateOffset <$> examStart oldExam
    , efEnd              = dateOffset <$> examEnd oldExam
    , efFinished         = dateOffset <$> examFinished oldExam
    , efClosed           = dateOffset <$> examClosed oldExam
    , efShowGrades       = examShowGrades oldExam
    , efPublicStatistics = examPublicStatistics oldExam
    , efDescription      = examDescription oldExam
    , efOccurrences      = Set.empty
    , efExamParts        = Set.empty
    , efCorrectors       = Set.empty
    }


validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamForm m ()
validateExam = do
  ExamForm{..} <- State.get

  guardValidation MsgExamRegisterToMustBeAfterRegisterFrom                 $ NTop efRegisterTo                   >= NTop efRegisterFrom
  guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom            $ NTop efDeregisterUntil              >= NTop efRegisterFrom
  guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments      . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
  guardValidation MsgExamEndMustBeAfterStart                               $ NTop efEnd                          >= NTop efStart
  guardValidation MsgExamFinishedMustBeAfterEnd                            . fromMaybe True $ (>=) <$> efFinished <*> efEnd
  guardValidation MsgExamFinishedMustBeAfterStart                          $ NTop efFinished                     >= NTop efStart
  guardValidation MsgExamClosedMustBeAfterFinished                         . fromMaybe True $ (>=) <$> efClosed <*> efFinished
  guardValidation MsgExamClosedMustBeAfterStart                            $ NTop efClosed                       >= NTop efStart
  guardValidation MsgExamClosedMustBeAfterEnd                              . fromMaybe True $ (>=) <$> efClosed <*> efEnd

  forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
    guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
    guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart
    guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd

  forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do
    eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a)

    guardValidation (MsgExamOccurrenceDuplicate (eofRoom a) eofRange') $ any (\f -> f a b)
      [ (/=) `on` eofRoom
      , (/=) `on` eofStart
      , (/=) `on` eofEnd
      , (/=) `on` fmap renderHtml . eofDescription
      ]

    guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b


getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCExamNewR = postCExamNewR
postCExamNewR tid ssh csh = do
  (cid, template) <- runDB $ do
    cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
    template <- examTemplate cid
    return (cid, template)

  ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm validateExam $ examForm template

  formResult newExamResult $ \ExamForm{..} -> do
    insertRes <- runDBJobs $ do
      insertRes <- insertUnique Exam
        { examName                         = efName
        , examCourse                       = cid
        , examGradingRule                  = efGradingRule
        , examBonusRule                    = efBonusRule
        , examOccurrenceRule               = efOccurrenceRule
        , examVisibleFrom                  = efVisibleFrom
        , examRegisterFrom                 = efRegisterFrom
        , examRegisterTo                   = efRegisterTo
        , examDeregisterUntil              = efDeregisterUntil
        , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments
        , examStart                        = efStart
        , examEnd                          = efEnd
        , examFinished                     = efFinished
        , examClosed                       = efClosed
        , examShowGrades                   = efShowGrades
        , examPublicStatistics             = efPublicStatistics
        , examDescription                  = efDescription
        }
      whenIsJust insertRes $ \examid -> do
        insertMany_
          [ ExamPart{..}
          | ExamPartForm{..} <- Set.toList efExamParts
          , let examPartExam      = examid
                examPartName      = epfName
                examPartMaxPoints = epfMaxPoints
                examPartWeight    = epfWeight
          ]

        insertMany_
          [ ExamOccurrence{..}
          | ExamOccurrenceForm{..} <- Set.toList efOccurrences
          , let examOccurrenceExam        = examid
                examOccurrenceName        = eofName
                examOccurrenceRoom        = eofRoom
                examOccurrenceCapacity    = eofCapacity
                examOccurrenceStart       = eofStart
                examOccurrenceEnd         = eofEnd
                examOccurrenceDescription = eofDescription
          ]

        let (invites, adds) = partitionEithers $ Set.toList efCorrectors
        insertMany_ [ ExamCorrector{..}
                    | examCorrectorUser <- adds
                    , let examCorrectorExam = examid
                    ]
        sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
      return insertRes
    case insertRes of
      Nothing -> addMessageI Error $ MsgExamNameTaken efName
      Just _  -> do
        addMessageI Success $ MsgExamCreated efName
        redirect $ CourseR tid ssh csh CExamListR

  let heading = prependCourseTitle tid ssh csh MsgExamNew

  siteLayoutMsg heading $ do
    setTitleI heading
    let
      newExamForm = wrapForm newExamWidget def
        { formMethod = POST
        , formAction = Just . SomeRoute $ CourseR tid ssh csh CExamNewR
        , formEncoding = newExamEnctype
        }
    $(widgetFile "exam-new")

getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEEditR = postEEditR
postEEditR tid ssh csh examn = do
  (cid, eId, template) <- runDB $ do
    (cid, exam@(Entity eId _)) <- fetchCourseIdExam tid ssh csh examn

    template <- examFormTemplate exam

    return (cid, eId, template)

  ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template

  formResult editExamResult $ \ExamForm{..} -> do
    insertRes <- runDBJobs $ do
      insertRes <- myReplaceUnique eId Exam
        { examCourse           = cid
        , examName             = efName
        , examGradingRule      = efGradingRule
        , examBonusRule        = efBonusRule
        , examOccurrenceRule   = efOccurrenceRule
        , examVisibleFrom      = efVisibleFrom
        , examRegisterFrom     = efRegisterFrom
        , examRegisterTo       = efRegisterTo
        , examDeregisterUntil  = efDeregisterUntil
        , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments
        , examStart            = efStart
        , examEnd              = efEnd
        , examFinished         = efFinished
        , examClosed           = efClosed
        , examPublicStatistics = efPublicStatistics
        , examShowGrades       = efShowGrades
        , examDescription      = efDescription
        }

      when (is _Nothing insertRes) $ do
        occIds <- fmap catMaybes . forM (Set.toList efOccurrences) $ traverse decrypt . eofId
        deleteWhere [ ExamOccurrenceExam ==. eId, ExamOccurrenceId /<-. occIds ]
        forM_ (Set.toList efOccurrences) $ \case
          ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_
            ExamOccurrence
              { examOccurrenceExam = eId
              , examOccurrenceName = eofName
              , examOccurrenceRoom = eofRoom
              , examOccurrenceCapacity = eofCapacity
              , examOccurrenceStart = eofStart
              , examOccurrenceEnd = eofEnd
              , examOccurrenceDescription = eofDescription
              }
          ExamOccurrenceForm{ .. } -> void . runMaybeT $ do
            cID <- hoistMaybe eofId
            eofId' <- decrypt cID
            oldOcc <- MaybeT $ get eofId'
            guard $ examOccurrenceExam oldOcc == eId
            lift $ replace eofId' ExamOccurrence
              { examOccurrenceExam = eId
              , examOccurrenceName = eofName
              , examOccurrenceRoom = eofRoom
              , examOccurrenceCapacity = eofCapacity
              , examOccurrenceStart = eofStart
              , examOccurrenceEnd = eofEnd
              , examOccurrenceDescription = eofDescription
              }


        pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId
        deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ]
        forM_ (Set.toList efExamParts) $ \case
          ExamPartForm{ epfId = Nothing, .. } -> insert_
            ExamPart
              { examPartExam = eId
              , examPartName = epfName
              , examPartMaxPoints = epfMaxPoints
              , examPartWeight = epfWeight
              }
          ExamPartForm{ .. } -> void . runMaybeT $ do
            cID <- hoistMaybe epfId
            epfId' <- decrypt cID
            oldPart <- MaybeT $ get epfId'
            guard $ examPartExam oldPart == eId
            lift $ replace epfId' ExamPart
              { examPartExam = eId
              , examPartName = epfName
              , examPartMaxPoints = epfMaxPoints
              , examPartWeight = epfWeight
              }


        let (invites, adds) = partitionEithers $ Set.toList efCorrectors

        deleteWhere [ ExamCorrectorExam ==. eId ]
        insertMany_ $ map (ExamCorrector eId) adds

        deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ]
        sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites

      return insertRes

    case insertRes of
      Just _  -> addMessageI Error $ MsgExamNameTaken efName
      Nothing -> do
        addMessageI Success $ MsgExamEdited efName
        redirect $ CExamR tid ssh csh efName EShowR

  let heading = prependCourseTitle tid ssh csh . MsgExamEditHeading $ efName template

  siteLayoutMsg heading $ do
    setTitleI heading
    let
      editExamForm = wrapForm editExamWidget def
        { formMethod = POST
        , formAction = Just . SomeRoute $ CExamR tid ssh csh examn EEditR
        , formEncoding = editExamEnctype
        }
    $(widgetFile "exam-edit")


getEShowR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEShowR tid ssh csh examn = do
  cTime <- liftIO getCurrentTime
  mUid <- maybeAuthId

  (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do
    exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn

    let examVisible = NTop (Just cTime) >= NTop examVisibleFrom

    let gradingVisible = NTop (Just cTime) >= NTop examFinished
    gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR

    let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
    occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR

    parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]

    resultsRaw <- for mUid $ \uid ->
      E.select . E.from $ \examPartResult -> do
        E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid
             E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey parts)
        return examPartResult
    let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw

    result <- fmap join . for mUid $ getBy . UniqueExamResult eId

    occurrencesRaw <- E.select . E.from $ \examOccurrence -> do
      E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId
      let
        registered
          | Just uid <- mUid
          = E.exists . E.from $ \examRegistration -> do
              E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId
                   E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
                   E.&&. examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId)
          | otherwise = E.false
      E.orderBy [E.desc registered, E.asc $ examOccurrence E.^. ExamOccurrenceStart, E.asc $ examOccurrence E.^. ExamOccurrenceRoom]
      return (examOccurrence, registered)

    let occurrences = map (over _2 E.unValue) occurrencesRaw

    registered <- for mUid $ existsBy . UniqueExamRegistration eId
    mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True

    occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR

    return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown)

  let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
      registerWidget
        | Just isRegistered <- registered
        , mayRegister = Just $ do
            (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
            [whamlet|
              <p>
                $if isRegistered
                  _{MsgExamRegistered}
                $else
                  _{MsgExamNotRegistered}
            |]
            wrapForm examRegisterForm def
              { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
              , formEncoding = examRegisterEnctype
              , formSubmit = FormNoSubmit
            }
        | fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|]
        | otherwise = Nothing

  let heading = prependCourseTitle tid ssh csh $ CI.original examName

  siteLayoutMsg heading $ do
    setTitleI heading
    let
      gradingKeyW :: [Points] -> Widget
      gradingKeyW bounds
        = let boundWidgets :: [Widget]
              boundWidgets = toWidget . (pack :: String -> Text) . showFixed True <$> 0 : bounds
              grades :: [ExamGrade]
              grades = universeF
           in $(widgetFile "widgets/gradingKey")

      examBonusW :: ExamBonusRule -> Widget
      examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
    $(widgetFile "exam-show")

type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))))
type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms))

instance HasEntity ExamUserTableData User where
  hasEntity = _dbrOutput . _2

instance HasUser ExamUserTableData where
  hasUser = _dbrOutput . _2 . _entityVal

_userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
_userTableOccurrence = _dbrOutput . _3

queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)

queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)

queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)

queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence))
queryExamOccurrence = $(sqlLOJproj 3 2)

queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)

queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)

resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration)
resultExamRegistration = _dbrOutput . _1

resultUser :: Lens' ExamUserTableData (Entity User)
resultUser = _dbrOutput . _2

resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures)
resultStudyFeatures = _dbrOutput . _4 . _Just

resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree)
resultStudyDegree = _dbrOutput . _5 . _Just

resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms)
resultStudyField = _dbrOutput . _6 . _Just

resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
resultExamOccurrence = _dbrOutput . _3 . _Just

data ExamUserTableCsv = ExamUserTableCsv
  { csvEUserSurname :: Maybe Text
  , csvEUserName :: Maybe Text
  , csvEUserMatriculation :: Maybe Text
  , csvEUserField :: Maybe Text
  , csvEUserDegree :: Maybe Text
  , csvEUserSemester :: Maybe Int
  , csvEUserOccurrence :: Maybe (CI Text)
  , csvEUserExercisePoints :: Maybe Points
  , csvEUserExercisePasses :: Maybe Int
  , csvEUserExercisePointsMax :: Maybe Points
  , csvEUserExercisePassesMax :: Maybe Int
  }
  deriving (Generic)

examUserTableCsvOptions :: Csv.Options
examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }

instance ToNamedRecord ExamUserTableCsv where
  toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions

instance FromNamedRecord ExamUserTableCsv where
  parseNamedRecord = Csv.genericParseNamedRecord examUserTableCsvOptions

instance DefaultOrdered ExamUserTableCsv where
  headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions

instance CsvColumnsExplained ExamUserTableCsv where
  csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList
    [ ('csvEUserSurname          , MsgCsvColumnExamUserSurname           )
    , ('csvEUserName             , MsgCsvColumnExamUserName              )
    , ('csvEUserMatriculation    , MsgCsvColumnExamUserMatriculation     )
    , ('csvEUserField            , MsgCsvColumnExamUserField             )
    , ('csvEUserDegree           , MsgCsvColumnExamUserDegree            )
    , ('csvEUserSemester         , MsgCsvColumnExamUserSemester          )
    , ('csvEUserOccurrence       , MsgCsvColumnExamUserOccurrence        )
    , ('csvEUserExercisePoints   , MsgCsvColumnExamUserExercisePoints    )
    , ('csvEUserExercisePasses   , MsgCsvColumnExamUserExercisePasses    )
    , ('csvEUserExercisePointsMax, MsgCsvColumnExamUserExercisePointsMax )
    , ('csvEUserExercisePassesMax, MsgCsvColumnExamUserExercisePassesMax )
    ]

data ExamUserAction = ExamUserDeregister
                    | ExamUserAssignOccurrence
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

instance Universe ExamUserAction
instance Finite ExamUserAction
nullaryPathPiece ''ExamUserAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''ExamUserAction id

data ExamUserActionData = ExamUserDeregisterData
                        | ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId)

data ExamUserCsvActionClass
  = ExamUserCsvCourseRegister
  | ExamUserCsvRegister
  | ExamUserCsvAssignOccurrence
  | ExamUserCsvSetCourseField
  | ExamUserCsvDeregister
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id

data ExamUserCsvAction
  = ExamUserCsvCourseRegisterData
    { examUserCsvActUser :: UserId
    , examUserCsvActCourseField :: Maybe StudyFeaturesId
    , examUserCsvActOccurrence :: Maybe ExamOccurrenceId
    }
  | ExamUserCsvRegisterData
    { examUserCsvActUser :: UserId
    , examUserCsvActOccurrence :: Maybe ExamOccurrenceId
    }
  | ExamUserCsvAssignOccurrenceData
    { examUserCsvActRegistration :: ExamRegistrationId
    , examUserCsvActOccurrence :: Maybe ExamOccurrenceId
    }
  | ExamUserCsvSetCourseFieldData
    { examUserCsvActCourseParticipant :: CourseParticipantId
    , examUserCsvActCourseField :: Maybe StudyFeaturesId
    }
  | ExamUserCsvDeregisterData
    { examUserCsvActRegistration :: ExamRegistrationId
    }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
  { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel
  , fieldLabelModifier = camelToPathPiece' 3
  , sumEncoding = TaggedObject "action" "data"
  } ''ExamUserCsvAction

data ExamUserCsvException
  = ExamUserCsvExceptionNoMatchingUser
  | ExamUserCsvExceptionNoMatchingStudyFeatures
  | ExamUserCsvExceptionNoMatchingOccurrence
  deriving (Show, Generic, Typeable)

instance Exception ExamUserCsvException

embedRenderMessage ''UniWorX ''ExamUserCsvException id

getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEUsersR = postEUsersR
postEUsersR tid ssh csh examn = do
  (registrationResult, examUsersTable) <- runDB $ do
    exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
    bonus <- examBonus exam

    let
      allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus
      showPasses     = numSheetsPasses allBoni /= 0
      showPoints     = getSum (numSheetsPoints allBoni) /= 0

    let
      examUsersDBTable = DBTable{..}
        where
          dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do
            E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
            E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
            E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
            E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
             E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
            E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
             E.&&. occurrence E.?. ExamOccurrenceId   E.==. examRegistration E.^. ExamRegistrationOccurrence
            E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
            E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
            return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField)
          dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
          dbtProj = return
          dbtColonnade = mconcat $ catMaybes
            [ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey)
            , pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
            , pure   colUserMatriclenr
            , pure $ colField            resultStudyField
            , pure $ colDegreeShort      resultStudyDegree
            , pure $ colFeaturesSemester resultStudyFeatures
            , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
            , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
                SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus
                SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus
                return $ propCell (getSum achievedPasses) (getSum numSheetsPasses)
            , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
                SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus
                SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus
                return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints)
            ]
          dbtSorting = Map.fromList
            [ sortUserNameLink     queryUser
            , sortUserSurname      queryUser
            , sortUserDisplayName  queryUser
            , sortUserMatriclenr   queryUser
            , sortField            queryStudyField
            , sortDegreeShort      queryStudyDegree
            , sortFeaturesSemester queryStudyFeatures
            , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
            ]
          dbtFilter = Map.fromList
            [ fltrUserNameEmail    queryUser
            , fltrUserMatriclenr   queryUser
            , fltrField            queryStudyField
            , fltrDegree           queryStudyDegree
            , fltrFeaturesSemester queryStudyFeatures
            , ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
            ]
          dbtFilterUI mPrev = mconcat
            [ fltrUserNameEmailUI    mPrev
            , fltrUserMatriclenrUI   mPrev
            , fltrFieldUI            mPrev
            , fltrDegreeUI           mPrev
            , fltrFeaturesSemesterUI mPrev
            , prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence)
            ]
          dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
          dbtParams = DBParamsForm
            { dbParamsFormMethod = POST
            , dbParamsFormAction = Just . SomeRoute $ CExamR tid ssh csh examn EUsersR
            , dbParamsFormAttrs  = []
            , dbParamsFormSubmit = FormSubmit
            , dbParamsFormAdditional = \csrf -> do
                let
                  actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData)
                  actionMap = Map.fromList
                    [ ( ExamUserDeregister
                      , pure ExamUserDeregisterData
                      )
                    , ( ExamUserAssignOccurrence
                      , ExamUserAssignOccurrenceData
                        <$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing)
                      )
                    ]
                (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
                let formRes = (, mempty) . First . Just <$> res
                return (formRes, formWgt)
            , dbParamsFormEvaluate = liftHandlerT . runFormPost
            , dbParamsFormResult   = id
            , dbParamsFormIdent    = def
            }
          dbtIdent :: Text
          dbtIdent = "exam-users"
          dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv
          dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv
            <$> view (resultUser . _entityVal . _userSurname . to Just)
            <*> view (resultUser . _entityVal . _userDisplayName . to Just)
            <*> view (resultUser . _entityVal . _userMatrikelnummer)
            <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
            <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
            <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
            <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
            <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped)
            <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral)
            <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped)
            <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral)
          dbtCsvDecode = Just DBTCsvDecode
            { dbtCsvRowKey = \csv -> do
                uid <- lift $ view _2 <$> guessUser csv
                fmap E.Value . MaybeT . getKeyBy $ UniqueExamRegistration eid uid
            , dbtCsvComputeActions = \case
                DBCsvDiffMissing{dbCsvOldKey}
                  -> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
                DBCsvDiffNew{dbCsvNewKey = Just _}
                  -> fail "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
                DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
                  (isPart, uid) <- lift $ guessUser dbCsvNew
                  if
                    | isPart -> do
                        yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
                        newFeatures <- lift $ lookupStudyFeatures dbCsvNew
                        Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse
                        when (newFeatures /= oldFeatures) $
                          yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
                    | otherwise ->
                        yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew
                DBCsvDiffExisting{..} -> do
                  newOccurrence <- lift $ lookupOccurrence dbCsvNew
                  when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $
                    yield $ ExamUserCsvAssignOccurrenceData (E.unValue dbCsvOldKey) newOccurrence

                  newFeatures <- lift $ lookupStudyFeatures dbCsvNew
                  when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do
                    Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
                    yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
            , dbtCsvClassifyAction = \case
                ExamUserCsvCourseRegisterData{}   -> ExamUserCsvCourseRegister
                ExamUserCsvRegisterData{}         -> ExamUserCsvRegister
                ExamUserCsvDeregisterData{}       -> ExamUserCsvDeregister
                ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
                ExamUserCsvSetCourseFieldData{}   -> ExamUserCsvSetCourseField
            , dbtCsvCoarsenActionClass = \case
                ExamUserCsvCourseRegister -> DBCsvActionNew
                ExamUserCsvRegister       -> DBCsvActionNew
                ExamUserCsvDeregister     -> DBCsvActionMissing
                _other                    -> DBCsvActionExisting 
            , dbtCsvExecuteActions = do
                C.mapM_ $ \case
                  ExamUserCsvCourseRegisterData{..} -> do
                    now <- liftIO getCurrentTime
                    insert_ CourseParticipant
                      { courseParticipantCourse = examCourse
                      , courseParticipantUser = examUserCsvActUser
                      , courseParticipantRegistration = now
                      , courseParticipantField = examUserCsvActCourseField
                      }
                    User{userIdent} <- getJust examUserCsvActUser
                    audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
                    insert_ ExamRegistration
                      { examRegistrationExam = eid
                      , examRegistrationUser = examUserCsvActUser
                      , examRegistrationOccurrence = examUserCsvActOccurrence
                      , examRegistrationTime = now
                      }
                  ExamUserCsvRegisterData{..} -> do
                    examRegistrationTime <- liftIO getCurrentTime
                    insert_ ExamRegistration
                      { examRegistrationExam = eid
                      , examRegistrationUser = examUserCsvActUser
                      , examRegistrationOccurrence = examUserCsvActOccurrence
                      , ..
                      }
                  ExamUserCsvAssignOccurrenceData{..} ->
                    update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ]
                  ExamUserCsvSetCourseFieldData{..} ->
                    update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ]
                  ExamUserCsvDeregisterData{..} -> do
                    ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration
                    User{userIdent} <- getJust examRegistrationUser
                    audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
                    delete examUserCsvActRegistration
                return $ CExamR tid ssh csh examn EUsersR
            , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
                ExamUserCsvCourseRegisterData{..} -> do
                  (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
                  [whamlet|
                    $newline never
                    ^{nameWidget userDisplayName userSurname}
                    $maybe features <- examUserCsvActCourseField
                      , ^{studyFeaturesWidget features}
                    $nothing
                      , _{MsgCourseStudyFeatureNone}
                    $maybe ExamOccurrence{examOccurrenceName} <- occ
                      \ (#{examOccurrenceName})
                    $nothing
                      \ (_{MsgExamNoOccurrence})
                  |]
                ExamUserCsvRegisterData{..} -> do
                  (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
                  [whamlet|
                    $newline never
                    ^{nameWidget userDisplayName userSurname}
                    $maybe ExamOccurrence{examOccurrenceName} <- occ
                      \ (#{examOccurrenceName})
                    $nothing
                      \ (_{MsgExamNoOccurrence})
                  |]
                ExamUserCsvAssignOccurrenceData{..} -> do
                  occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust
                  [whamlet|
                    $newline never
                    ^{registeredUserName' examUserCsvActRegistration}
                    $maybe ExamOccurrence{examOccurrenceName} <- occ
                      \ (#{examOccurrenceName})
                    $nothing
                      \ (_{MsgExamNoOccurrence})
                  |]
                ExamUserCsvSetCourseFieldData{..} -> do
                  User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
                  [whamlet|
                    $newline never
                    ^{nameWidget userDisplayName userSurname}
                    $maybe features <- examUserCsvActCourseField
                      , ^{studyFeaturesWidget features}
                    $nothing
                      , _{MsgCourseStudyFeatureNone}
                  |]
                ExamUserCsvDeregisterData{..}
                  -> registeredUserName' examUserCsvActRegistration
            , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
            , dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text
            }
            where
              studyFeaturesWidget :: StudyFeaturesId -> Widget
              studyFeaturesWidget featId = do
                (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
                [whamlet|
                  $newline never
                  _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
                |]
               
              registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget
              registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
                where
                  Entity _ User{..} = view resultUser $ existing ! registration
              
              guessUser :: ExamUserTableCsv -> DB (Bool, UserId)
              guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do
                users <- E.select . E.from $ \user -> do
                  E.where_ . E.and $ catMaybes
                    [ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation
                    , (user E.^. UserDisplayName E.==.) . E.val <$> csvEUserName
                    , (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname
                    ]
                  let isCourseParticipant = E.exists . E.from $ \courseParticipant ->
                        E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse
                             E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
                  E.limit 2
                  return $ (isCourseParticipant, user E.^. UserId)
                case users of
                  (filter . view $ _1 . _Value -> [(E.Value isPart, E.Value uid)])
                    -> return (isPart, uid)
                  [(E.Value isPart, E.Value uid)]
                    -> return (isPart, uid)
                  _other
                    -> throwM ExamUserCsvExceptionNoMatchingUser

              lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId)
              lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do
                occIds <- selectKeysList [ ExamOccurrenceName ==. occName, ExamOccurrenceExam ==. eid ] []
                case occIds of
                  [occId] -> return occId
                  _other  -> throwM ExamUserCsvExceptionNoMatchingOccurrence

              lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId)
              lookupStudyFeatures csv@ExamUserTableCsv{..} = do
                uid <- view _2 <$> guessUser csv
                studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> do
                  E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
                  E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
                  E.where_ . E.and $ catMaybes 
                    [ do
                        field <- csvEUserField
                        return . E.or $ catMaybes
                          [ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field)
                          , Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field)
                          , (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field
                          ]
                    , do
                        degree <- csvEUserDegree
                        return . E.or $ catMaybes
                          [ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree)
                          , Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree)
                          , (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree
                          ]
                    , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester
                    ]
                  E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
                       E.&&. studyFeatures E.^. StudyFeaturesType E.==. E.val FieldPrimary
                       E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True
                  E.limit 2
                  return $ studyFeatures E.^. StudyFeaturesId
                case studyFeatures of
                  [E.Value fid] -> return $ Just fid
                  _other
                    | is _Nothing csvEUserField
                    , is _Nothing csvEUserDegree
                    , is _Nothing csvEUserSemester
                    -> return Nothing
                  _other        -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures

      examUsersDBTableValidator = def

      postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamRegistrationId)
      postprocess inp = do
        (First (Just act), regMap) <- inp
        let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap
        return (act, regSet)
    over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable

  formResult registrationResult $ \case
    (ExamUserDeregisterData, selectedRegistrations) -> do
      nrDel <- runDB $ deleteWhereCount
        [ ExamRegistrationId <-. Set.toList selectedRegistrations
        ]
      addMessageI Success $ MsgExamUsersDeregistered nrDel
      redirect $ CExamR tid ssh csh examn EUsersR
    (ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do
      nrUpdated <- runDB $ updateWhereCount
        [ ExamRegistrationId <-. Set.toList selectedRegistrations
        ]
        [ ExamRegistrationOccurrence =. occId
        ]
      addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated
      redirect $ CExamR tid ssh csh examn EUsersR

  siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
    setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
    $(widgetFile "exam-users")


getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEAddUserR = postEAddUserR
postEAddUserR = error "postEAddUserR"

getEInviteR, postEInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEInviteR = postEInviteR
postEInviteR = error "postEInviteR"

postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
postERegisterR tid ssh csh examn = do
  Entity uid User{..} <- requireAuth

  Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn

  ((btnResult, _), _) <- runFormPost buttonForm

  formResult btnResult $ \case
    BtnExamRegister -> do
      runDB $ do
        now <- liftIO getCurrentTime
        insert_ $ ExamRegistration eId uid Nothing now
        audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
      addMessageWidget Success [whamlet|
          <div>#{iconExamRegister True}
          <div>&nbsp;
          <div>_{MsgExamRegisteredSuccess   examn}
          |]
      redirect $ CExamR tid ssh csh examn EShowR
    BtnExamDeregister -> do
      runDB $ do
        deleteBy $ UniqueExamRegistration eId uid
        audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
      addMessageWidget Info [whamlet|
        <div>#{iconExamRegister False}
        <div>&nbsp;
        <div>_{MsgExamDeregisteredSuccess examn}
        |] -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4
      redirect $ CExamR tid ssh csh examn EShowR

  invalidArgs ["Register/Deregister button required"]