fradrive/src/Handler/Exam/AutoOccurrence.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Handler.Exam.AutoOccurrence
  ( examAutoOccurrenceCalculateWidget
  , postEAutoOccurrenceR
  ) where

import Import
import Handler.Utils
import Handler.Utils.Exam

import qualified Data.Map as Map

import qualified Database.Esqueleto as E
import Database.Persist.Sql (updateWhereCount)


newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm
  { eaofConfig :: ExamAutoOccurrenceConfig
  } deriving stock   (Eq, Ord, Read, Show, Generic, Typeable)
    deriving newtype (Default, FromJSON, ToJSON)

makeLenses_ ''ExamAutoOccurrenceCalculateForm

data ExamAutoOccurrenceAcceptForm = ExamAutoOccurrenceAcceptForm
  { eaofMapping    :: Maybe (ExamOccurrenceMapping ExamOccurrenceId)
  , eaofAssignment :: Map UserId (Maybe ExamOccurrenceId)
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)

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

data ExamAutoOccurrenceButton
  = BtnExamAutoOccurrenceCalculate
  | BtnExamAutoOccurrenceAccept
  | BtnExamAutoOccurrenceNudgeUp | BtnExamAutoOccurrenceNudgeDown
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe ExamAutoOccurrenceButton
instance Finite ExamAutoOccurrenceButton

nullaryPathPiece ''ExamAutoOccurrenceButton $ camelToPathPiece' 4

embedRenderMessage ''UniWorX ''ExamAutoOccurrenceButton id
instance Button UniWorX ExamAutoOccurrenceButton where
  btnClasses BtnExamAutoOccurrenceNudgeUp = [BCIsButton]
  btnClasses BtnExamAutoOccurrenceNudgeDown = [BCIsButton]
  btnClasses _ = [BCIsButton, BCPrimary]


examAutoOccurrenceCalculateForm :: ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm
examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig }
  = identifyForm FIDExamAutoOccurrenceCalculate . renderAForm FormStandard $ ExamAutoOccurrenceCalculateForm <$> eaocForm
  where
    eaocForm = 
      (set _eaocMinimizeRooms <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just $ eaofConfig ^. _eaocMinimizeRooms))
      <*> pure def

examAutoOccurrenceNudgeForm :: ExamOccurrenceId -> Maybe ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm
examAutoOccurrenceNudgeForm occId protoForm html = do
  cID <- encrypt occId
  (btnRes, wgt) <- identifyForm (FIDExamAutoOccurrenceNudge $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceNudgeUp, BtnExamAutoOccurrenceNudgeDown]) html
  oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField
  oldDataId <- newIdent
  
  let protoForm' = fromMaybe def $ oldDataRes <|> protoForm
      genForm btn = protoForm' & _eaofConfig . _eaocNudge %~ Map.insertWith (+) occId n
        where n = case btn of
                BtnExamAutoOccurrenceNudgeUp   ->  1
                BtnExamAutoOccurrenceNudgeDown -> -1
                _other                         -> 0
      res = genForm <$> btnRes
      oldDataView = fieldView (secretJsonField :: Field Handler _) oldDataId (toPathPiece PostExamAutoOccurrencePrevious) [] (Right . fromMaybe protoForm' $ formResult' res) False
  return (res, wgt <> oldDataView)

examAutoOccurrenceAcceptForm :: Maybe ExamAutoOccurrenceAcceptForm -> Form ExamAutoOccurrenceAcceptForm
examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceConfirm $ \html -> do
  (confirmDataRes, confirmDataView) <- mreq secretJsonField "" confirmData
  (acceptRes, acceptView) <- buttonForm' [BtnExamAutoOccurrenceAccept] mempty
  return (acceptRes *> confirmDataRes, toWidget html <> fvWidget confirmDataView <> acceptView)


examAutoOccurrenceCalculateWidget :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Widget
examAutoOccurrenceCalculateWidget tid ssh csh examn = do
  (formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm def
  
  wrapForm' BtnExamAutoOccurrenceCalculate $(i18nWidgetFile "exam-auto-occurrence-calculate") def
    { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
    , formEncoding
    }
      

postEAutoOccurrenceR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
postEAutoOccurrenceR tid ssh csh examn = do
  (Entity eId Exam{ examOccurrenceRule }, occurrences) <- runDB $ do
    exam@(Entity eId _) <- fetchExam tid ssh csh examn
    occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [ Asc ExamOccurrenceName ]
    return (exam, occurrences)
  
  
  ((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm def

  nudgeRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId ->
    runFormPost $ examAutoOccurrenceNudgeForm occId (formResult' calculateRes)

  let calculateRes' = asum $ calculateRes : nudgeRes ^.. folded . _1 . _1

  calcResult <- formResultMaybe calculateRes' $ \ExamAutoOccurrenceCalculateForm{..} -> runDB $ do
    participants <- E.select . E.from $ \(registration `E.InnerJoin` user) -> do
      E.on $ registration E.^. ExamRegistrationUser E.==. user E.^. UserId
      E.where_ $ registration E.^. ExamRegistrationExam E.==. E.val eId
      return (user, registration)
    let participants' = Map.fromList $ do
          (Entity uid userRec, Entity _ ExamRegistration{..}) <- participants
          return (uid, (userRec, examRegistrationOccurrence))
        occurrences' = Map.fromList $ map (\(Entity eoId ExamOccurrence{..}) -> (eoId, examOccurrenceCapacity)) occurrences
        (eaofMapping, eaofAssignment) = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants'
    return $ Just ExamAutoOccurrenceAcceptForm{..}

  ((confirmRes, confirmView), confirmEncoding) <- runFormPost $ examAutoOccurrenceAcceptForm calcResult
  let confirmWidget = wrapForm confirmView def
        { formAction   = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
        , formEncoding = confirmEncoding
        , formSubmit   = FormNoSubmit
        }

  formResult confirmRes $ \ExamAutoOccurrenceAcceptForm{..} -> do
    Sum assignedCount <- runDB $ do
      let eaofMapping'' :: Maybe (Maybe (ExamOccurrenceMapping ExamOccurrenceName))
          eaofMapping'' = (<$> eaofMapping) . traverseExamOccurrenceMapping $ \eoId -> case filter ((== eoId) . entityKey) occurrences of
            [Entity _ ExamOccurrence{..}] -> Just examOccurrenceName
            _other -> Nothing
      eaofMapping' <- case eaofMapping'' of
        Nothing        -> return Nothing
        Just  Nothing  -> invalidArgsI [MsgExamAutoOccurrenceOccurrencesChangedInFlight]
        Just (Just x ) -> return $ Just x
      update eId [ ExamExamOccurrenceMapping =. eaofMapping' ]
      fmap fold . iforM eaofAssignment $ \pid occ -> case occ of
        Just _  -> Sum <$> updateWhereCount [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. pid, ExamRegistrationOccurrence ==. Nothing ] [ ExamRegistrationOccurrence =. occ ]
        Nothing -> return mempty
    addMessageI Success $ MsgExamAutoOccurrenceParticipantsAssigned assignedCount
    redirect $ CExamR tid ssh csh examn EUsersR

  let nudgeWgt = nudgeRes <&> \((_, nudgeView), nudgeEncoding) ->
        wrapForm nudgeView def
          { formAction   = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
          , formEncoding = nudgeEncoding
          , formSubmit   = FormNoSubmit
          , formAttrs = [("class", "buttongroup")]
          }

  ExamAutoOccurrenceAcceptForm{..} <- maybe (redirect $ CExamR tid ssh csh examn EUsersR) return calcResult

  let heading = MsgTitleExamAutoOccurrence tid ssh csh examn
      mappingWgt
        = let occLoads :: Map ExamOccurrenceId Natural
              occLoads = Map.fromListWith (+) . mapMaybe (\(_, mOcc) -> (, 1) <$> mOcc) $ Map.toList eaofAssignment

              occLoad = fromMaybe 0 . flip Map.lookup occLoads

              occMappingRule = examOccurrenceMappingRule <$> eaofMapping

              loadProp curr max'
                | max' /= 0 = MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max')
                | otherwise = MsgProportionNoRatio (toMessage curr) (toMessage max')

              occMapping occId = examOccurrenceMappingDescriptionWidget <$> occMappingRule <*> (Map.lookup occId . examOccurrenceMappingMapping =<< eaofMapping)
           in $(widgetFile "widgets/exam-occurrence-mapping")

  siteLayoutMsg heading $ do
    setTitleI heading
    $(widgetFile "exam/auto-occurrence-confirm")