module Handler.Tutorial where

import Import
import Handler.Utils
import Handler.Utils.Tutorial
import Handler.Utils.Table.Cells
import Handler.Utils.Delete
import Handler.Utils.Communication
import Handler.Utils.Form.MassInput
import Handler.Utils.Form.Occurences

import qualified Database.Esqueleto 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.CaseInsensitive as CI

import qualified Data.Text as Text

import Utils.Lens

{-# ANN module ("Hlint: ignore Redundant void" :: String) #-}


getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCTutorialListR tid ssh csh = do
  Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh

  let
    tutorialDBTable = DBTable{..}
      where
        dbtSQLQuery tutorial = do
          E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
          let participants = E.sub_select . E.from $ \tutorialParticipant -> do
                E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
                return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
          return (tutorial, participants)
        dbtRowKey = (E.^. TutorialId)
        dbtProj = return . over (_dbrOutput . _2) E.unValue
        dbtColonnade = dbColonnade $ mconcat
          [ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell $ CI.original tutorialType
          , sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell $ CI.original tutorialName
          , sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = (Entity tutid _, _) } -> sqlCell $ do
              tutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
                E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
                E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
                return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
              return [whamlet|
                       <ul .list--iconless .list--inline .list--comma-separated>
                         $forall tutor <- tutors
                           <li>
                             ^{nameEmailWidget' tutor}
                     |]
          , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) . toWidget $ tshow n
          , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity
          , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom
          , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurencesCell tutorialTime
          , sortable (Just "reg-group") (i18nCell MsgTutorialRegGroup) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . CI.original) tutorialRegGroup
          , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterFrom
          , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterTo
          , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialDeregisterUntil
          , sortable Nothing mempty $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> cell $ do
              linkButton mempty [whamlet|_{MsgTutorialEdit}|] [BCIsButton] . SomeRoute $ CTutorialR tid ssh csh tutorialName TEditR
              linkButton mempty [whamlet|_{MsgTutorialDelete}|] [BCIsButton, BCDanger] . SomeRoute $ CTutorialR tid ssh csh tutorialName TDeleteR
          ]
        dbtSorting = Map.fromList
          [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
          , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
          , ("participants", SortColumn $ \tutorial -> E.sub_select . E.from $ \tutorialParticipant -> do
                E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
                return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
            )
          , ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity )
          , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
          , ("reg-grep", SortColumn $ \tutorial -> tutorial E.^. TutorialRegGroup )
          , ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
          , ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo )
          , ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil )
          ]
        dbtFilter = Map.empty
        dbtFilterUI = const mempty
        dbtStyle = def
        dbtParams = def
        dbtIdent :: Text
        dbtIdent = "tutorials"

    tutorialDBTableValidator = def
      & defaultSorting [SortAscBy "type", SortAscBy "name"]
  ((), tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable

  siteLayoutMsg (prependCourseTitle tid ssh csh MsgTutorialsHeading) $ do
    setTitleI $ prependCourseTitle tid ssh csh MsgTutorialsHeading
    $(widgetFile "tutorial-list")

postTRegisterR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler ()
postTRegisterR tid ssh csh tutn = do
  uid <- requireAuthId

  Entity tutid Tutorial{..} <- runDB $ fetchTutorial tid ssh csh tutn

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

  formResult btnResult $ \case
    BtnRegister -> do
      runDB . void . insert $ TutorialParticipant tutid uid
      addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName
      redirect $ CourseR tid ssh csh CShowR
    BtnDeregister -> do
      runDB . deleteBy $ UniqueTutorialParticipant tutid uid
      addMessageI Success $ MsgTutorialDeregisteredSuccess tutorialName
      redirect $ CourseR tid ssh csh CShowR

  invalidArgs ["Register/Deregister button required"]

getTDeleteR, postTDeleteR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTDeleteR = postTDeleteR
postTDeleteR tid ssh csh tutn = do
  tutid <- runDB $ fetchTutorialId tid ssh csh tutn
  deleteR DeleteRoute
    { drRecords = Set.singleton tutid
    , drUnjoin = \(_ `E.InnerJoin` tutorial) -> tutorial
    , drGetInfo = \(course `E.InnerJoin` tutorial) -> do
        E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
        let participants = E.sub_select . E.from $ \participant -> do
              E.where_ $ participant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
              return E.countRows
        return (course, tutorial, participants :: E.SqlExpr (E.Value Int))
    , drRenderRecord = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
        return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (#{tshow ps} _{MsgParticipantsN ps})|]
    , drRecordConfirmString = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
        return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{tutorialName}+#{tshow ps}|]
    , drCaption = SomeMessage MsgTutorialDeleteQuestion
    , drSuccessMessage = SomeMessage MsgTutorialDeleted
    , drAbort = SomeRoute $ CTutorialR tid ssh csh tutn TUsersR
    , drSuccess = SomeRoute $ CourseR tid ssh csh CTutorialListR
    }

getTCommR, postTCommR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTCommR = postTCommR
postTCommR tid ssh csh tutn = do
  jSender <- requireAuthId
  (cid, tutid) <- runDB $ fetchCourseIdTutorialId tid ssh csh tutn

  commR CommunicationRoute
    { crHeading    = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading
    , crUltDest    = SomeRoute $ CTutorialR tid ssh csh tutn TCommR
    , crJobs       = \Communication{..} -> do
        let jSubject = cSubject
            jMailContent = cBody
            jCourse = cid
            allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
        jMailObjectUUID <- liftIO getRandom
        jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
          Left email -> return . Address Nothing $ CI.original email
          Right rid  -> userAddress <$> getJust rid
        forM_ allRecipients $ \jRecipientEmail ->
          yield JobSendCourseCommunication{..}
    , crRecipients = Map.fromList
      [ ( RGTutorialParticipants
        , E.from $ \(user `E.InnerJoin` participant) -> do
            E.on $ user E.^. UserId E.==. participant E.^. TutorialParticipantUser
            E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
            return user
        )
      , ( RGCourseLecturers
        , E.from $ \(user `E.InnerJoin` lecturer) -> do
            E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
            E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
            return user
        )
      , ( RGCourseCorrectors
        , E.from $ \user -> do
            E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do
              E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
              E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
            return user
        )
      , ( RGCourseTutors
        , E.from $ \user -> do
            E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do
              E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
              E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
            return user
        )
      ]
    , crRecipientAuth = Just $ \uid -> do
        cID <- encrypt uid
        evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
    }


data TutorialForm = TutorialForm
  { tfName            :: TutorialName
  , tfType            :: CI Text
  , tfCapacity        :: Maybe Int
  , tfRoom            :: Text
  , tfTime            :: Occurences
  , tfRegGroup        :: Maybe (CI Text)
  , tfRegisterFrom    :: Maybe UTCTime
  , tfRegisterTo      :: Maybe UTCTime
  , tfDeregisterUntil :: Maybe UTCTime
  , tfTutors          :: Set UserId -- awaiting feat/generic-invitations
  }

tutorialForm :: CourseId -> Maybe TutorialForm -> Form TutorialForm
tutorialForm cid template html = do
  MsgRenderer mr <- getMsgRenderer
  Just cRoute <- getCurrentRoute
  uid <- liftHandlerT requireAuthId

  let 
    tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template)
      where
        miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([UserId] -> FormResult [UserId])
        miAdd' nudge submitView csrf = do
          (addRes, addView) <- mpreq (multiUserField False . Just $ tutUserSuggestions uid) ("" & addName (nudge "email")) Nothing
          let
            addRes'
              | unresolved <- toListOf (_FormSuccess . folded . _Left) addRes
              , (fUnresolved : _) <- unresolved
              = FormFailure [mr $ MsgEMailUnknown fUnresolved]
              | otherwise
              = addRes <&> \newDat oldDat -> if
                  | (_ : _) <- Set.toList $ setOf (folded . _Right) newDat `Set.intersection` Set.fromList oldDat
                    -> FormFailure [mr MsgTutorialTutorAlreadyAdded]
                  | otherwise
                    -> FormSuccess $ toListOf (folded . _Right) newDat
          return (addRes', $(widgetFile "tutorial/tutorMassInput/add"))


        miCell' :: UserId -> Widget
        miCell' userId = do
          User{..} <- liftHandlerT . runDB $ get404 userId
          $(widgetFile "tutorial/tutorMassInput/cellKnown")

        miLayout' :: MassInputLayout ListLength UserId ()
        miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "tutorial/tutorMassInput/layout")
  
  flip (renderAForm FormStandard) html $ TutorialForm
    <$> areq ciField (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template)
    <*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template)
    <*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template)
    <*> areq textField (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template)
    <*> occurencesAForm (tfTime <$> template)
    <*> fmap (assertM (not . Text.null . CI.original) . fmap (CI.map Text.strip)) (aopt ciField (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial")))
    <*> aopt utcTimeField   (fslpI MsgRegisterFrom (mr MsgDate)
                               & setTooltip MsgCourseRegisterFromTip
                            ) (tfRegisterFrom <$> template)
    <*> aopt utcTimeField   (fslpI MsgRegisterTo   (mr MsgDate)
                               & setTooltip MsgCourseRegisterToTip
                            ) (tfRegisterTo <$> template)
    <*> aopt utcTimeField   (fslpI MsgDeRegUntil   (mr MsgDate)
                               & setTooltip MsgCourseDeregisterUntilTip
                            ) (tfDeregisterUntil <$> template)
    <*> tutorForm
  where
    tutTypeDatalist :: WidgetT UniWorX IO (Set (CI Text))
    tutTypeDatalist = liftHandlerT . runDB $
      fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
        E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
        return $ tutorial E.^. TutorialType

    tutUserSuggestions :: UserId -> E.SqlQuery (E.SqlExpr (Entity User))
    tutUserSuggestions uid = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` tutorial `E.InnerJoin` tutor `E.InnerJoin` tutorUser) -> do
      E.on $ tutorUser E.^. UserId E.==. tutor E.^. TutorUser
      E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
      E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId
      E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
      E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
      return tutorUser


getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCTutorialNewR = postCTutorialNewR
postCTutorialNewR tid ssh csh = do
  Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
  
  ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing

  formResult newTutResult $ \TutorialForm{..} -> do
    insertRes <- runDB $ do
      now <- liftIO getCurrentTime
      insertRes <- insertUnique Tutorial
        { tutorialName            = tfName
        , tutorialCourse          = cid
        , tutorialType            = tfType
        , tutorialCapacity        = tfCapacity
        , tutorialRoom            = tfRoom
        , tutorialTime            = tfTime
        , tutorialRegGroup        = tfRegGroup
        , tutorialRegisterFrom    = tfRegisterFrom
        , tutorialRegisterTo      = tfRegisterTo
        , tutorialDeregisterUntil = tfDeregisterUntil
        , tutorialLastChanged     = now
        }
      forM_ tfTutors $ \tutor -> case insertRes of
        Just tutid -> void . insert $ Tutor tutid tutor
        _other     -> return ()
      return insertRes
    case insertRes of
      Nothing -> addMessageI Error $ MsgTutorialNameTaken tfName
      Just _  -> do
        addMessageI Success $ MsgTutorialCreated tfName
        redirect $ CourseR tid ssh csh CTutorialListR

  let heading = prependCourseTitle tid ssh csh MsgTutorialNew

  siteLayoutMsg heading $ do
    setTitleI heading
    let
      newTutForm = wrapForm newTutWidget def
        { formMethod = POST
        , formAction = Just . SomeRoute $ CourseR tid ssh csh CTutorialNewR
        , formEncoding = newTutEnctype
        }
    $(widgetFile "tutorial-new")

getTEditR, postTEditR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTEditR = postTEditR
postTEditR tid ssh csh tutn = do
  (cid, tutid, template) <- runDB $ do
    (cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn

    tutorIds <- fmap (map E.unValue) . E.select . E.from $ \tutor -> do
      E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
      return $ tutor E.^. TutorUser

    let
      template = TutorialForm
        { tfName            = tutorialName
        , tfType            = tutorialType
        , tfCapacity        = tutorialCapacity
        , tfRoom            = tutorialRoom
        , tfTime            = tutorialTime
        , tfRegGroup        = tutorialRegGroup
        , tfRegisterFrom    = tutorialRegisterFrom
        , tfRegisterTo      = tutorialRegisterTo
        , tfDeregisterUntil = tutorialDeregisterUntil
        , tfTutors          = Set.fromList tutorIds
        }

    return (cid, tutid, template)

  ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost . tutorialForm cid $ Just template

  formResult newTutResult $ \TutorialForm{..} -> do
    insertRes <- runDB $ do
      now <- liftIO getCurrentTime
      insertRes <- myReplaceUnique tutid Tutorial
        { tutorialName            = tfName
        , tutorialCourse          = cid
        , tutorialType            = tfType
        , tutorialCapacity        = tfCapacity
        , tutorialRoom            = tfRoom
        , tutorialTime            = tfTime
        , tutorialRegGroup        = tfRegGroup
        , tutorialRegisterFrom    = tfRegisterFrom
        , tutorialRegisterTo      = tfRegisterTo
        , tutorialDeregisterUntil = tfDeregisterUntil
        , tutorialLastChanged     = now
        }
      deleteWhere [ TutorTutorial ==. tutid ]
      forM_ tfTutors $ void . insert . Tutor tutid
      return insertRes
    case insertRes of
      Just _  -> addMessageI Error $ MsgTutorialNameTaken tfName
      Nothing -> do
        addMessageI Success $ MsgTutorialCreated tfName
        redirect $ CourseR tid ssh csh CTutorialListR

  let heading = prependCourseTitle tid ssh csh . MsgTutorialEditHeading $ tfName template

  siteLayoutMsg heading $ do
    setTitleI heading
    let
      newTutForm = wrapForm newTutWidget def
        { formMethod = POST
        , formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutn TEditR
        , formEncoding = newTutEnctype
        }
    $(widgetFile "tutorial-edit")