module Handler.Course.Register
  ( ButtonCourseRegister(..)
  , CourseRegisterForm(..)
  , courseRegisterForm
  , getCRegisterR, postCRegisterR
  ) where

import Import

import Handler.Utils

import Data.Function ((&))

import qualified Data.Text as Text

import qualified Data.Conduit.List as C

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


-- Dedicated CourseRegistrationButton
data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister | BtnCourseApply | BtnCourseRetractApplication
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonCourseRegister
instance Finite ButtonCourseRegister
nullaryPathPiece ''ButtonCourseRegister $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonCourseRegister id
instance Button UniWorX ButtonCourseRegister where
  btnClasses BtnCourseRegister           = [BCIsButton, BCPrimary]
  btnClasses BtnCourseDeregister         = [BCIsButton, BCDanger]
  btnClasses BtnCourseApply              = [BCIsButton, BCPrimary]
  btnClasses BtnCourseRetractApplication = [BCIsButton, BCDanger]

  btnLabel   BtnCourseRegister           = [whamlet|#{iconEnrol True}  _{MsgBtnCourseRegister}|]
  btnLabel   BtnCourseDeregister         = [whamlet|#{iconEnrol False} _{MsgBtnCourseDeregister}|]
  btnLabel   BtnCourseApply              = [whamlet|#{iconApply True}  _{MsgBtnCourseApply}|]
  btnLabel   BtnCourseRetractApplication = [whamlet|#{iconApply False} _{MsgBtnCourseRetractApplication}|]


data CourseRegisterForm = CourseRegisterForm
  { crfStudyFeatures    :: Maybe StudyFeaturesId
  , crfApplicationText  :: Maybe Text
  , crfApplicationFiles :: Maybe (Source Handler File)
  }

courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -> m (AForm Handler CourseRegisterForm, ButtonCourseRegister)
-- ^ `CourseRegisterForm` for current user
courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do
  muid <- maybeAuthId
  (registration, application) <- runDB $ do
    registration <- fmap join . for muid $ getBy . flip UniqueParticipant cid
    application <- fmap (listToMaybe =<<) . for muid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] []
    return (registration, application)
  let btn | courseApplicationsRequired
          , is _Just application
          = BtnCourseRetractApplication
          | is _Just registration
          = BtnCourseDeregister
          | courseApplicationsRequired
          = BtnCourseApply
          | otherwise
          = BtnCourseRegister
      isRegistered = btn `elem` [BtnCourseRetractApplication, BtnCourseDeregister]
  return . (, btn) . wFormToAForm $ do
    MsgRenderer mr <- getMsgRenderer
    
    secretRes <- if
      | Just secret <- courseRegisterSecret
      , not isRegistered
        -> let guardSecret (FormSuccess secret')
                 | secret == secret' = return $ FormSuccess ()
                 | otherwise         = formFailure [MsgCourseSecretWrong]
               guardSecret  FormMissing       = return   FormMissing
               guardSecret (FormFailure errs) = return $ FormFailure errs
            in guardSecret =<< wreq textField (fslpI MsgCourseSecret $ mr MsgCourseSecret) Nothing
      | otherwise
        -> return $ FormSuccess ()

    fieldRes <- if
      | is _Nothing muid
        -> return $ FormSuccess Nothing
      | is _Just muid
      , isRegistered
      , Just mFeature <- courseApplicationField . entityVal <$> application
                     <|> courseParticipantField . entityVal <$> registration
        -> wforced (studyFeaturesFieldFor Nothing True  (maybeToList mFeature) muid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) mFeature
      | otherwise
        -> wreq    (studyFeaturesFieldFor Nothing False []                     muid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing

    appTextRes <- let fs | courseApplicationsRequired
                         , is _Just courseApplicationsInstructions
                         = fslI MsgCourseApplicationText & setTooltip MsgCourseApplicationFollowInstructions
                         | courseApplicationsRequired
                         = fslI MsgCourseApplicationText
                         | is _Just courseApplicationsInstructions
                         = fslI MsgCourseRegistrationText & setTooltip MsgCourseRegistrationFollowInstructions
                         | otherwise
                         = fslI MsgCourseRegistrationText
                      textField' = convertField unTextarea Textarea textareaField
                   in if
      | not courseApplicationsText
        -> return $ FormSuccess Nothing
      | is _Just muid
      , isRegistered
        -> wforced (convertField Just (fromMaybe Text.empty) textField') fs (application >>= courseApplicationText . entityVal)
      | otherwise
        -> fmap (assertM (not . Text.null) . fmap Text.strip) <$> wopt textField' fs (Just $ application >>= courseApplicationText . entityVal)

    hasFiles <- for application $ \(Entity appId _)
      -> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ]
    appCID <- for application $ encrypt . entityKey
    let appFilesInfo = (,) <$> hasFiles <*> appCID
        filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired

    when (isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles) $
      let filesLinkField = Field{..}
            where
              fieldParse _ _ = return $ Right Nothing
              fieldEnctype = mempty
              fieldView theId _ attrs _ _
                = [whamlet|
                    $newline never
                      $case appFilesInfo
                        $of Just (True, appCID)
                          <a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}>
                            _{filesMsg}
                        $of _
                          <span ##{theId} *{attrs}>
                            _{MsgCourseApplicationNoFiles}
                  |]
       in void $ wforced filesLinkField (fslI filesMsg) Nothing

    when (fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles) $
      wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired

    appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive
                            | otherwise                  = bool MsgCourseRegistrationFile MsgCourseRegistrationArchive
                    in if
      | isRegistered
        -> return $ FormSuccess Nothing
      | otherwise
        -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles
      
    return $ CourseRegisterForm
      <$  secretRes
      <*> fieldRes
      <*> appTextRes
      <*> appFilesRes

 
-- | Workaround for klicking register button without being logged in.
-- After log in, the user sees a "get request not supported" error.
getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCRegisterR tid ssh csh = do
  muid <- maybeAuthId
  case muid of
    Nothing -> addMessageI Info MsgLoginNecessary
    (Just uid) -> runDB $ do
      cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
      registration <- getBy (UniqueParticipant uid cid)
      when (isNothing registration) $ addMessageI Warning MsgRegisterRetry
  redirect $ CourseR tid ssh csh CShowR

postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCRegisterR tid ssh csh = do
  uid <- requireAuthId
  course@(Entity cid Course{..}) <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
  (courseRegisterForm', courseRegisterButton) <- courseRegisterForm course
  ((regResult,_), _) <- runFormPost $ renderAForm FormStandard courseRegisterForm'
  formResult regResult $ \CourseRegisterForm{..} -> do
    cTime <- liftIO getCurrentTime
    let
      mkApplication
        | courseApplicationsRequired || is _Just (void crfApplicationText <|> void crfApplicationFiles)
        = void <$> do
            appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
            appRes <- case appIds of
              [] -> insertUnique $ CourseApplication cid uid crfStudyFeatures crfApplicationText False Nothing Nothing Nothing Nothing cTime Nothing
              (prevId:ps) -> do
                forM_ ps $ \appId -> do
                  deleteApplicationFiles appId
                  delete appId
                  audit $ TransactionCourseApplicationDeleted cid uid appId

                deleteApplicationFiles prevId
                update prevId [ CourseApplicationField =. crfStudyFeatures, CourseApplicationText =. crfApplicationText, CourseApplicationTime =. cTime ]

                return $ Just prevId

            whenIsJust appRes $ 
              audit . TransactionCourseApplicationEdit cid uid 
            whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do
              runConduit $ transPipe liftHandlerT fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId)
            return appRes
        | otherwise
        = return $ Just ()
      mkRegistration = do
        audit $ TransactionCourseParticipantEdit cid uid
        insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures False

      deleteApplications = do
        appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
        forM_ appIds $ \appId -> do
          deleteApplicationFiles appId
          delete appId
          audit $ TransactionCourseApplicationDeleted cid uid appId

      deleteApplicationFiles appId = do
        fs <- selectList [ CourseApplicationFileApplication ==. appId ] []
        deleteCascadeWhere [ FileId <-. map (courseApplicationFileFile . entityVal) fs ]
    case courseRegisterButton of
      BtnCourseRegister -> runDB $ do
        regOk <- (\app reg -> (,) <$> app <*> reg) <$> mkApplication <*> mkRegistration
        case regOk of
          Nothing -> transactionUndo
          Just _  -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
      BtnCourseDeregister -> runDB $ do
        deleteApplications
        part <- getBy $ UniqueParticipant uid cid
        forM_ part $ \(Entity partId CourseParticipant{..}) -> do
          delete $ partId
          audit $ TransactionCourseParticipantDeleted cid uid

          when courseParticipantAllocated $ do
            now <- liftIO getCurrentTime
            insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing

        examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do
          E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
          E.where_ $ exam E.^. ExamCourse E.==. E.val cid
               E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
          return examRegistration
        forM_ examRegistrations $ \(Entity erId ExamRegistration{..}) -> do
          delete erId
          audit $ TransactionExamDeregister examRegistrationExam uid

        examResults <- E.select . E.from $ \(examResult `E.InnerJoin` exam) -> do
          E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
          E.where_ $ exam E.^. ExamCourse E.==. E.val cid
               E.&&. examResult E.^. ExamResultUser E.==. E.val uid
          return examResult
        forM_ examResults $ \(Entity erId ExamResult{..}) -> do
          delete erId
          audit $ TransactionExamResultDeleted examResultExam uid
  
        addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
      BtnCourseApply -> runDB $ do
        regOk <- mkApplication
        case regOk of
          Nothing -> transactionUndo
          Just _  -> addMessageIconI Success IconApplyTrue MsgCourseApplyOk
      BtnCourseRetractApplication -> runDB $ do
        deleteApplications
        addMessageIconI Info IconApplyFalse MsgCourseRetractApplyOk
  redirect $ CourseR tid ssh csh CShowR
