module Handler.Allocation.Application
  ( AllocationApplicationButton(..)
  , ApplicationFormView(..)
  , ApplicationForm(..)
  , ApplicationFormMode(..)
  , ApplicationFormException(..)
  , applicationForm, editApplicationR
  , postAApplyR
  ) where

import Import hiding (hash)

import Handler.Utils
import qualified Data.Text as Text
import qualified Data.Set as Set

import qualified Database.Esqueleto.Legacy as E

import qualified Data.Conduit.List as C


data AllocationApplicationButton
  = BtnAllocationApply
  | BtnAllocationApplicationEdit
  | BtnAllocationApplicationRetract
  | BtnAllocationApplicationRate
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe AllocationApplicationButton
instance Finite AllocationApplicationButton

nullaryPathPiece ''AllocationApplicationButton $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''AllocationApplicationButton id
makePrisms ''AllocationApplicationButton

instance Button UniWorX AllocationApplicationButton where
  btnLabel BtnAllocationApply              = [whamlet|#{iconApply True} _{MsgBtnAllocationApply}|]
  btnLabel BtnAllocationApplicationRetract = [whamlet|#{iconApply False} _{MsgBtnAllocationApplicationRetract}|]
  btnLabel BtnAllocationApplicationEdit    = [whamlet|#{iconAllocationApplicationEdit} _{MsgBtnAllocationApplicationEdit}|]
  btnLabel BtnAllocationApplicationRate = i18n BtnAllocationApplicationRate
  
  btnClasses BtnAllocationApplicationRetract = [BCIsButton, BCDanger]
  btnClasses _ = [BCIsButton, BCPrimary]


data ApplicationFormView = ApplicationFormView
  { afvPriority :: Maybe (FieldView UniWorX)
  , afvForm     :: [FieldView UniWorX]
  , afvButtons  :: ([AllocationApplicationButton], Widget)
  }

data ApplicationForm = ApplicationForm
  { afPriority      :: Maybe Word64
  , afText          :: Maybe Text
  , afFiles         :: Maybe FileUploads
  , afRatingVeto    :: Bool
  , afRatingPoints  :: Maybe ExamGrade
  , afRatingComment :: Maybe Text
  , afAction        :: AllocationApplicationButton
  }

data ApplicationFormMode = ApplicationFormMode
  { afmApplicant     :: Bool -- ^ Show priority
  , afmApplicantEdit :: Bool -- ^ Allow editing text, files, priority (if shown)
  , afmLecturer      :: Bool -- ^ Allow editing rating
  }


data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill forced fields of application form with data from application
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Exception ApplicationFormException

applicationForm :: Maybe AllocationId
                -> CourseId
                -> Maybe UserId
                -> ApplicationFormMode -- ^ Which parts of the shared form to display
                -> Maybe Html -- ^ If @Just@ also include action buttons for usage as standalone form
                -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsrf = do

  (mApp, coursesNum, Course{..}, maxPrio) <- liftHandler . runDB $ do
    mApplication <- fmap join . for muid $ \uid -> listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
    coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
    course <- getJust cid
    (fromMaybe 0 -> maxPrio) <- fmap join . for muid $ \uid -> fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \courseApplication -> do
      E.where_ $ courseApplication E.^. CourseApplicationUser       E.==. E.val uid
           E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
           E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
      return . E.joinV . E.max_ $ courseApplication E.^. CourseApplicationAllocationPriority
    return (mApplication, coursesNum, course, maxPrio)
  MsgRenderer mr <- getMsgRenderer

  let
    oldPrio :: Maybe Word64
    oldPrio = mApp >>= courseApplicationAllocationPriority . entityVal

    coursesNum' = succ maxPrio `max` coursesNum

    mkPrioOption :: Word64 -> Option Word64
    mkPrioOption i = Option
      { optionDisplay       = mr . MsgAllocationCoursePriority . fromIntegral $ coursesNum' - i
      , optionInternalValue = i
      , optionExternalValue = tshow i
      }

    prioOptions :: OptionList Word64
    prioOptions = OptionList
      { olOptions = sortOn (Down . optionInternalValue) . map mkPrioOption $ [0 .. pred coursesNum']
      , olReadExternal = readMay
      }
    prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions

  (prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of
    (True , True , True , _)
      | is _Nothing mApp || is _Nothing mcsrf
        -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just oldPrio)
    (True , True , True , Just _ )
      -> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio
    (True , True , False, _      )
      -> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio
    (True , False, _    , Just _ )
      | is _Just oldPrio
        -> pure (FormSuccess oldPrio, Nothing)
    (True , _    , _    , _      )
      -> throwM ApplicationFormNoApplication
    (False, _    , _    , _      )
      -> pure (FormSuccess Nothing, Nothing)

  let textField' = convertField (Text.strip . unTextarea) Textarea textareaField
      textFs
        | is _Just courseApplicationsInstructions
        = fslI MsgCourseApplicationText & setTooltip MsgCourseApplicationFollowInstructions
        | otherwise
        = fslI MsgCourseApplicationText
  (textRes, textView) <- if
    | not courseApplicationsText
      -> pure (FormSuccess Nothing, Nothing)
    | not afmApplicantEdit
      -> over _2 Just <$> mforcedOpt textField' textFs (mApp >>= courseApplicationText . entityVal)
    | otherwise
      -> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' textFs (Just $ mApp >>= courseApplicationText . entityVal)

  appFilesInfo <- for mApp $ \(Entity appId _) -> liftHandler . runDB $ do
    hasFiles <- exists [ CourseApplicationFileApplication ==. appId ]
    appCID <- encrypt appId
    appFilesLink <- toTextUrl $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR
    return (hasFiles, appFilesLink)
  let hasFiles = maybe False (view _1) appFilesInfo

  filesLinkView <- if
    | hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
      -> let filesLinkField = Field{..}
               where
                 fieldParse _ _ = return $ Right Nothing
                 fieldEnctype = mempty
                 fieldView theId _ attrs _ _
                   = [whamlet|
                       $newline never
                         $case appFilesInfo
                           $of Just (True, appFilesLink)
                             <a ##{theId} *{attrs} href=#{appFilesLink}>
                               _{MsgCourseApplicationFiles}
                           $of _
                             <span ##{theId} *{attrs}>
                               _{MsgCourseApplicationNoFiles}
                     |]
          in Just . snd <$> mforced filesLinkField (fslI MsgCourseApplicationFiles) ()
    | otherwise
      -> return Nothing

  filesWarningView <- if
    | hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
      -> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload
    | otherwise
      -> return Nothing

  (filesRes, filesView) <-
    let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive
        prevAppFiles (Entity aId _) = runDBSource $ selectSource [CourseApplicationFileApplication ==. aId] [Asc CourseApplicationFileTitle] .| C.map (view $ _FileReference . _1)
     in if
      | not afmApplicantEdit || is _NoUpload courseApplicationsFiles
        -> return (FormSuccess Nothing, Nothing)
      | otherwise
        -> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles (prevAppFiles <$> mApp)

  (vetoRes, vetoView) <- if
    | afmLecturer
      -> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp)
    | otherwise
      -> return (FormSuccess $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp, Nothing)

  (pointsRes, pointsView) <- if
    | afmLecturer
      -> over _2 Just <$> mopt examGradeField (fslI MsgApplicationRatingPoints & setTooltip MsgApplicationRatingPointsTip) (fmap Just $ mApp >>= courseApplicationRatingPoints . entityVal)
    | otherwise
      -> return (FormSuccess $ courseApplicationRatingPoints . entityVal =<< mApp, Nothing)

  (commentRes, commentView) <- if
    | afmLecturer
      -> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' (fslI MsgApplicationRatingComment & setTooltip (bool MsgApplicationRatingCommentInvisibleTip MsgApplicationRatingCommentVisibleTip courseApplicationsRatingsVisible)) (fmap Just $ mApp >>= courseApplicationRatingComment . entityVal)
    | otherwise
      -> return (FormSuccess $ courseApplicationRatingComment . entityVal =<< mApp, Nothing)

  let
    buttons = catMaybes
      [ guardOn (not afmApplicantEdit && is _Just    mApp && afmLecturer) BtnAllocationApplicationRate
      , guardOn (    afmApplicantEdit && is _Just    mApp               ) BtnAllocationApplicationEdit
      , guardOn (    afmApplicantEdit && is _Nothing mApp               ) BtnAllocationApply
      , guardOn (    afmApplicantEdit && is _Just    mApp               ) BtnAllocationApplicationRetract
      ]
  (actionRes, buttonsView) <- case mcsrf of
    Just csrf -> buttonForm' buttons csrf
    Nothing   -> return (pure BtnAllocationApplicationEdit, mempty)

  ratingSection <- if
    | afmLecturer
    , afmApplicantEdit
      -> Just . set _fvTooltip (Just . toHtml $ mr MsgApplicationRatingSectionSelfTip) . snd <$> formSection MsgApplicationRatingSection
    | afmLecturer
      -> Just . snd <$> formSection MsgApplicationRatingSection
    | otherwise
      -> return Nothing

  return ( ApplicationForm
           <$> prioRes
           <*> textRes
           <*> filesRes
           <*> vetoRes
           <*> pointsRes
           <*> commentRes
           <*> actionRes
         , ApplicationFormView
           { afvPriority = prioView
           , afvForm = catMaybes $
             [ textView
             , filesLinkView
             , filesWarningView
             ] ++ maybe [] (map Just) filesView ++
             [ ratingSection
             , vetoView
             , pointsView
             , commentView
             ]
           , afvButtons = (buttons, buttonsView)
           }
         )




editApplicationR :: Maybe AllocationId
                 -> UserId
                 -> CourseId
                 -> Maybe CourseApplicationId
                 -> ApplicationFormMode
                 -> (AllocationApplicationButton -> Bool)
                 -> SomeRoute UniWorX
                 -> Handler (ApplicationFormView, Enctype)
editApplicationR maId uid cid mAppId afMode allowAction postAction = do
  Course{..} <- runDB $ get404 cid

  ((appRes, appView), appEnc) <- runFormPost $ applicationForm maId cid (Just uid) afMode . Just

  formResult appRes $ \ApplicationForm{..} -> do
    if
      | BtnAllocationApply <- afAction
      , allowAction afAction
      , is _Nothing maId || is _Just afPriority
        -> runDB . setSerializable $ do
          haveOld <- exists [ CourseApplicationCourse     ==. cid
                            , CourseApplicationUser       ==. uid
                            , CourseApplicationAllocation ==. maId
                            ]
          when haveOld $
            invalidArgsI [MsgCourseApplicationExists]

          now <- liftIO getCurrentTime
          let rated = afRatingVeto || is _Just afRatingPoints

          appId <- insert CourseApplication
            { courseApplicationCourse             = cid
            , courseApplicationUser               = uid
            , courseApplicationText               = afText
            , courseApplicationRatingVeto         = afRatingVeto
            , courseApplicationRatingPoints       = afRatingPoints
            , courseApplicationRatingComment      = afRatingComment
            , courseApplicationAllocation         = maId
            , courseApplicationAllocationPriority = afPriority
            , courseApplicationTime               = now
            , courseApplicationRatingTime         = guardOn rated now
            }

          runConduit $ transPipe liftHandler (sequence_ afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
          audit $ TransactionCourseApplicationEdit cid uid appId
          addMessageI Success $ MsgCourseApplicationCreated courseShorthand
      | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
      , allowAction afAction
      , Just appId <- mAppId
      , is _Nothing maId || is _Just afPriority
        -> runDB . setSerializable $ do
          now <- liftIO getCurrentTime

          changes <- if
            | afmApplicantEdit afMode
              -> let mkFilter CourseApplicationFileResidual{..} = [ CourseApplicationFileApplication ==. courseApplicationFileResidualApplication ]
                  in view _2 <$> replaceFileReferences mkFilter (CourseApplicationFileResidual appId) (forM_ afFiles id)
            | otherwise
              -> return Set.empty

          oldApp <- get404 appId
          let newApp = oldApp
                { courseApplicationText               = afText
                , courseApplicationRatingVeto         = afRatingVeto
                , courseApplicationRatingPoints       = afRatingPoints
                , courseApplicationRatingComment      = afRatingComment
                , courseApplicationAllocation         = maId
                , courseApplicationAllocationPriority = afPriority
                }

              newRating = any (\f -> f oldApp newApp)
                [ (/=) `on` courseApplicationRatingVeto
                , (/=) `on` courseApplicationRatingPoints
                , (/=) `on` courseApplicationRatingComment
                ]
              hasRating = any ($ newApp)
                [ courseApplicationRatingVeto
                , is _Just . courseApplicationRatingPoints
                ]

              appChanged = any (\f -> f oldApp newApp)
                [ (/=) `on` courseApplicationText
                , \_ _ -> not $ Set.null changes
                ]

              newApp' = newApp
                & bool id (set _courseApplicationRatingTime Nothing) appChanged
                & bool id (set _courseApplicationRatingTime $ Just now) (newRating && hasRating)
                & bool id (set _courseApplicationTime now) appChanged
          replace appId newApp'
          audit $ TransactionCourseApplicationEdit cid uid appId

          uncurry addMessageI =<< case (afmLecturer afMode, newRating, hasRating, appChanged) of
            (_, False, _, True) -> return (Success, MsgCourseApplicationEdited courseShorthand)
            (_, False, _, False) -> return (Info, MsgCourseApplicationNotEdited courseShorthand)
            (True, True, True, _) -> return (Success, MsgCourseApplicationRated)
            (True, True, False, _) -> return (Success, MsgCourseApplicationRatingDeleted)
            (False, True, _, _) -> permissionDenied "rating changed without lecturer rights"
      | is _BtnAllocationApplicationRetract afAction
      , allowAction afAction
      , Just appId <- mAppId
        -> runDB $ do
          delete appId
          audit $ TransactionCourseApplicationDeleted cid uid appId
          addMessageI Success $ MsgCourseApplicationDeleted courseShorthand
      | otherwise
        -> invalidArgsI [MsgCourseApplicationInvalidAction]

    redirect postAction

  return (appView, appEnc)


postAApplyR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDCourse -> Handler Void
postAApplyR tid ssh ash cID = do
  uid <- requireAuthId
  cid <- decrypt cID
  (aId, Course{..}) <- runDB $ do
    aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash
    course <- get404 cid
    return (aId, course)

  afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR

  let afMode = ApplicationFormMode
        { afmApplicant = True
        , afmApplicantEdit = True
        , afmLecturer
        }

  void . editApplicationR (Just aId) uid cid Nothing afMode (== BtnAllocationApply) . SomeRoute $ AllocationR tid ssh ash AShowR :#: cID

  invalidArgs ["Application form required"]
