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

module Handler.Course.Users
  ( queryUser
  , makeCourseUserTable
  , postCUsersR, getCUsersR
  , colUserDegreeShort, colUserField, colUserSemester
  ) where

import Import

import Utils.Form
import Handler.Utils
import Handler.Utils.Database
import Handler.Utils.Table.Cells
import Handler.Utils.Table.Columns
import Database.Persist.Sql (deleteWhereCount)
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH

import Data.Function ((&))

import qualified Data.Set as Set
import qualified Data.Map as Map

import qualified Database.Esqueleto as E


type UserTableExpr   = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant))
        `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
        `E.LeftOuterJoin`
        (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin`E.SqlExpr (Maybe (Entity StudyTerms)))

-- forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a)
-- forceUserTableType = id

-- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions)
-- This ought to ease refactoring the query
queryUser :: UserTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)

queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant)
queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)

queryUserNote ::  UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
queryUserNote = $(sqlLOJproj 3 2)

queryFeaturesStudy ::  UserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
queryFeaturesStudy  = $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)

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

queryFeaturesField :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
queryFeaturesField  = $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)


userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User)
                                                          , E.SqlExpr (E.Value UTCTime)
                                                          , E.SqlExpr (E.Value (Maybe (Key CourseUserNote)))
                                                          , StudyFeaturesDescription')
userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures) = do
  -- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis
  features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures
  E.on $  (note E.?. CourseUserNoteUser   E.==. E.just (participant E.^. CourseParticipantUser))
    E.&&. (note E.?. CourseUserNoteCourse E.==. E.just (E.val cid))
  E.on $     participant E.^. CourseParticipantUser   E.==. user E.^. UserId
  E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
  return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, features)


type UserTableData   = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId, (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms))

instance HasEntity UserTableData User where
  hasEntity = _dbrOutput . _1

instance HasUser UserTableData where
  -- hasUser = _entityVal
  hasUser = _dbrOutput . _1 . _entityVal

_userTableRegistration :: Lens' UserTableData UTCTime
_userTableRegistration = _dbrOutput . _2

_userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
_userTableNote = _dbrOutput . _3

_userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
_userTableFeatures = _dbrOutput . _4

_rowUserSemester :: Traversal' UserTableData Int
_rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester


colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
colUserComment tid ssh csh =
    sortable (Just "note") (i18nCell MsgCourseUserNote)
      $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey,_) } ->
        maybeEmpty mbNoteKey $ const $
          anchorCellM (courseLink <$> encrypt uid) (hasComment True)
  where
    courseLink = CourseR tid ssh csh . CUserR

colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $
    foldMap numCell . preview _rowUserSemester

colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserField = sortable (Just "field") (i18nCell MsgCourseStudyFeature) $
    foldMap i18nCell . view (_userTableFeatures . _3)

-- colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
-- colUserFieldShort = sortable (Just "field-short") (i18nCell MsgCourseStudyFeature) $
--     foldMap (i18nCell . ShortStudyTerms) . view (_userTableFeatures . _3)

-- colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
-- colUserDegree = sortable (Just "degree") (i18nCell MsgStudyFeatureDegree) $
--     foldMap i18nCell . preview (_userTableFeatures . _2 . _Just)

colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
    foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)


data CourseUserAction = CourseUserSendMail | CourseUserDeregister
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

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


makeCourseUserTable :: forall h acts.
                       ( Functor h, ToSortable h
                       , MonoFoldable acts
                       , RenderMessage UniWorX (Element acts), Eq (Element acts), PathPiece (Element acts)
                       )
                    => CourseId
                    -> acts
                    -> (UserTableExpr -> E.SqlExpr (E.Value Bool))
                    -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData)))
                    -> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData))
                    -> DB (FormResult (Element acts, Set UserId), Widget)
makeCourseUserTable cid acts restrict colChoices psValidator = do
    Just currentRoute <- liftHandlerT getCurrentRoute
    -- -- psValidator has default sorting and filtering
    let dbtIdent     = "courseUsers" :: Text
        dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
        dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
        dbtRowKey    = queryUser >>> (E.^. UserId)
        dbtProj      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
        dbtColonnade = colChoices
        dbtSorting   = Map.fromList
          [ sortUserNameLink    queryUser -- slower sorting through clicking name column header
          , sortUserSurname     queryUser -- needed for initial sorting
          , sortUserDisplayName queryUser -- needed for initial sorting
          , sortUserEmail       queryUser
          , sortUserMatriclenr  queryUser
          , ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
          , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
          , ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
          , ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
          , ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
          , ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
          , ("note"        , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
                E.sub_select . E.from $ \edit -> do
                  E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
                  return . E.max_ $ edit E.^. CourseUserNoteEditTime
            )
          ]
        dbtFilter    = Map.fromList
          [ fltrUserNameLink    queryUser
          , fltrUserEmail       queryUser
          , fltrUserMatriclenr  queryUser
          , fltrUserNameEmail   queryUser
          , ("field-name"  , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
          , ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
          , ("field-key"   , FilterColumn $ E.mkExactFilter    $ queryFeaturesField >>> (E.?. StudyTermsKey))
          , ("field"       , FilterColumn $ E.anyFilter
                                 [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
                                 , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
                                 , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
                                 ] )
          , ("degree"      , FilterColumn $ E.anyFilter
                                 [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
                                 , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
                                 , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
                                 ] )
          , ("semesternr"  , FilterColumn $ E.mkExactFilter    $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
          , ("tutorial"    , FilterColumn $ E.mkExistsFilter   $ \row criterion ->
                E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
                  E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
                  E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
                       E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
                       E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
            )
          -- , ("course-registration", error "TODO") -- TODO
          -- , ("course-user-note", error "TODO") -- TODO
          ]
        dbtFilterUI mPrev = mconcat
          [ fltrUserNameEmailUI  mPrev
          , fltrUserMatriclenrUI mPrev
          , prismAForm (singletonFilter "degree")   mPrev $ aopt textField (fslI MsgStudyFeatureDegree)
          , prismAForm (singletonFilter "field")    mPrev $ aopt textField (fslI MsgCourseStudyFeature)
          , prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseTutorial)
          ]
        dbtParams    = DBParamsForm
          { dbParamsFormMethod = POST
          , dbParamsFormAction = Just $ SomeRoute currentRoute
          , dbParamsFormAttrs  = []
          , dbParamsFormSubmit = FormSubmit
          , dbParamsFormAdditional
              = renderAForm FormStandard
                   $  (, mempty) . First . Just
                  <$> areq (selectField $ optionsF acts) (fslI MsgAction) Nothing
          , dbParamsFormEvaluate = liftHandlerT . runFormPost
          , dbParamsFormResult   = id
          , dbParamsFormIdent    = def
          }
        dbtCsvEncode = noCsvEncode
        dbtCsvDecode = Nothing
    over _1 postprocess <$> dbTable psValidator DBTable{..}
  where
    postprocess :: FormResult (First act, DBFormResult UserId Bool UserTableData) -> FormResult (act, Set UserId)
    postprocess inp = do
      (First (Just act), usrMap) <- inp
      let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
      return (act, usrSet)

getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCUsersR = postCUsersR
postCUsersR tid ssh csh = do
  (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do
    mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
    let colChoices  = mconcat
          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
          , colUserNameLink (CourseR tid ssh csh . CUserR)
          , colUserEmail
          , colUserMatriclenr
          , colUserDegreeShort
          , colUserField
          , colUserSemester
          , sortable (Just "registration") (i18nCell MsgRegisteredSince) (dateCell . view _userTableRegistration)
          , colUserComment tid ssh csh
          ]
        psValidator = def & defaultSortingByName
        acts = catMaybes
          [ Just CourseUserSendMail
          , guardOn mayRegister CourseUserDeregister
          ]
    ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
    numParticipants <- count [CourseParticipantCourse ==. cid]
    table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator
    return (ent, numParticipants, table)
  formResult participantRes $ \case
    (CourseUserSendMail, selectedUsers) -> do
        cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
        redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
    (CourseUserDeregister,selectedUsers) -> do
        Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> do
          nrDel <- deleteWhereCount
            [ CourseParticipantCourse ==. cid
            , CourseParticipantUser ==. uid
            ]
          unless (nrDel == 0) $
            audit $ TransactionCourseParticipantDeleted cid uid
          return $ Sum nrDel
        addMessageI Success $ MsgCourseUsersDeregistered nrDel
        redirect $ CourseR tid ssh csh CUsersR
  let headingLong  = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|]
      headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
  siteLayout headingLong $ do
    setTitleI headingShort
    $(widgetFile "course-participants")