module Handler.Utils.Communication
  ( RecipientGroup(..)
  , CommunicationRoute(..)
  , Communication(..)
  , commR
  , crJobsCourseCommunication, crTestJobsCourseCommunication
  -- * Re-Exports
  , Job(..)
  ) where

import Import
import Handler.Utils

import Jobs.Queue

import qualified Database.Esqueleto.Legacy as E
import qualified Data.CaseInsensitive as CI
import Data.Map ((!), (!?))
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Data.Conduit.Combinators as C


data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors | RGCourseParticipantsInTutorial | RGCourseUnacceptedApplicants
                    | RGTutorialParticipants CryptoUUIDTutorial
                    | RGExamRegistered CryptoUUIDExam
                    | RGSheetSubmittor CryptoUUIDSheet
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

instance LowerBounded RecipientGroup where
  minBound' = RGCourseParticipants

derivePathPiece ''RecipientGroup (camelToPathPiece' 1) "--"
pathPieceJSON ''RecipientGroup


data RecipientCategory
  = RecipientGroup RecipientGroup
  | RecipientCustom
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

instance LowerBounded RecipientCategory where
  minBound' = RecipientGroup minBound'

instance PathPiece RecipientCategory where
  toPathPiece RecipientCustom    = "custom"
  toPathPiece (RecipientGroup g) = toPathPiece g

  fromPathPiece "custom" = Just RecipientCustom
  fromPathPiece t        = RecipientGroup <$> fromPathPiece t

pathPieceJSON ''RecipientCategory
pathPieceJSONKey ''RecipientCategory

data CommunicationButton
  = BtnCommunicationSend
  | BtnCommunicationTest
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
  deriving anyclass (Universe, Finite)

nullaryPathPiece ''CommunicationButton $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''CommunicationButton id
makePrisms ''CommunicationButton

instance Button UniWorX CommunicationButton where
  btnClasses BtnCommunicationSend = [BCIsButton, BCPrimary]
  btnClasses BtnCommunicationTest = [BCIsButton]


data CommunicationRoute = CommunicationRoute
  { crRecipients    :: [(RecipientGroup, E.SqlQuery (E.SqlExpr (Entity User)))]
  , crRecipientAuth :: Maybe (UserId -> DB AuthResult) -- ^ Only resolve userids given as GET-Parameter if they fulfil this criterion
  , crJobs, crTestJobs :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
  , crHeading       :: SomeMessage UniWorX
  , crUltDest       :: SomeRoute UniWorX
  }

data Communication = Communication
 { cRecipients :: Set (Either UserEmail UserId)
 , cContent :: CommunicationContent
 }

makeLenses_ ''Communication


crJobsCourseCommunication, crTestJobsCourseCommunication :: CourseId -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
crJobsCourseCommunication jCourse Communication{..} = do
  jSender <- requireAuthId
  let jMailContent = cContent
      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{..}
crTestJobsCourseCommunication jCourse comm = do
  jSender <- requireAuthId

  MsgRenderer mr <- getMsgRenderer
  let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommCourseSubject)
  crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail)


commR :: CommunicationRoute -> Handler Html
commR CommunicationRoute{..} =  do
  cUser <- maybeAuth

  MsgRenderer mr <- getMsgRenderer
  mbCurrentRoute <- getCurrentRoute

  (suggestedRecipients, chosenRecipients) <- runDB $ do
    suggestedUsers <- for crRecipients $ \(_,user) -> E.select user
    let suggested = zip (view _1 <$> crRecipients) suggestedUsers

    let
      decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User))
      decrypt' cID = do
        uid <- decrypt cID
        whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid)
        getEntity uid

    chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient

    return (suggested, chosen')

  let
    lookupUser :: UserId -> User
    lookupUser lId
      = entityVal . unsafeHead . filter ((== lId) . entityKey) $ concat (view _2 <$> suggestedRecipients) ++ chosenRecipients

  let chosenRecipients' = Map.fromList $
        [ ( (BoundedPosition $ RecipientGroup g, pos)
          , (Right recp, recp `elem` map entityKey chosenRecipients)
          )
        | (g, recps) <- suggestedRecipients
        , (pos, recp) <- zip [0..] $ map entityKey recps
        ] ++
        [ ( (BoundedPosition   RecipientCustom, pos)
          , (Right recp, True)
          )
        | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients)
        ]
      activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom

  let recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
      recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
        where
          miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do
            (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing
            let
              addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails
            return (addRes', $(widgetFile "widgets/communication/recipientAdd"))
          miAdd _ _ _ _ _ = Nothing
          miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
            (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
            return (tickRes, $(widgetFile "widgets/communication/recipientEmail"))
          miCell _ (Right uid@(lookupUser -> User{..})) initRes nudge csrf = do
            (tickRes, tickView) <- if
              | fmap entityKey cUser == Just uid
                -> mforced checkBoxField ("" & addName (nudge "tick"))   True
              | otherwise
                -> mpreq   checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
            return (tickRes, $(widgetFile "widgets/communication/recipientName"))
          miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True
          miAllowAdd _ _ _ = False
          miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0)
          miAddEmpty _ _ _ = Set.empty
          miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX)
          miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute
          miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength
                   -> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool)
                   -> Map (BoundedPosition RecipientCategory, ListPosition) Widget
                   -> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX)
                   -> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget
                   -> Widget
          miLayout liveliness cState cellWdgts _delButtons addWdgts = do
            checkedIdentBase <- newIdent
            let checkedCategories = Set.mapMonotonic (unBoundedPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState
                checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c
                hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts
                categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness
                rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget
                rgTutorialParticipantsCaption cID = do
                  tutId <- decrypt cID
                  Tutorial{..} <- liftHandler . runDBRead $ get404 tutId
                  i18n $ MsgRGTutorialParticipants tutorialName
                rgExamRegisteredCaption :: CryptoUUIDExam -> Widget
                rgExamRegisteredCaption cID = do
                  eId <- decrypt cID
                  Exam{..} <- liftHandler . runDBRead $ get404 eId
                  i18n $ MsgRGExamRegistered examName
                rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget
                rgSheetSubmittorCaption cID = do
                  sId <- decrypt cID
                  Sheet{..} <- liftHandler . runDBRead $ get404 sId
                  i18n $ MsgRGSheetSubmittor sheetName
            $(widgetFile "widgets/communication/recipientLayout")
          miDelete :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (BoundedPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (BoundedPosition RecipientCategory, ListPosition) (BoundedPosition RecipientCategory, ListPosition))
          -- miDelete liveliness@(MapLiveliness lMap) (BoundedPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(BoundedPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (BoundedPosition RecipientCustom, ) . Map.mapKeysMonotonic (BoundedPosition RecipientCustom, ) <$> miDeleteList (lMap ! BoundedPosition RecipientCustom) delPos
          miDelete _ _ = mzero
          miIdent :: Text
          miIdent = "recipients"
          postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId)
          postProcess = Set.fromList . map fst . filter snd . Map.elems

  recipientsListMsg <- messageI Info MsgCommRecipientsList

  attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize
  let attachmentField = genericFileField $ return FileField
        { fieldIdent = Nothing
        , fieldUnpackZips = FileFieldUserOption True False
        , fieldMultiple = True
        , fieldRestrictExtensions = Nothing
        , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty
        , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize
        , fieldAllEmptyOk = True
        }
  ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication
    <$> recipientAForm
    <*  aformMessage recipientsListMsg
    <*> ( CommunicationContent
            <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing
            <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing)
            <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing)
        )
  formResult commRes $ \case
    (comm, BtnCommunicationSend) -> do
      runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs
      addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm
      redirect crUltDest
    (comm, BtnCommunicationTest) -> do
      runDBJobs . runConduit $ transPipe (mapReaderT lift) (crTestJobs comm) .| sinkDBJobs
      addMessageI Info MsgCommTestSuccess

  let formWdgt = wrapForm commWdgt def
        { formMethod   = POST
        , formAction   = SomeRoute <$> mbCurrentRoute
        , formEncoding = commEncoding
        , formSubmit   = FormNoSubmit
        }
  siteLayoutMsg crHeading $ do
    setTitleI crHeading
    let commTestTip = $(i18nWidgetFile "comm-test-tip")
    [whamlet|
       $newline never
       <section>
         ^{formWdgt}
       <section .explanation>
         ^{commTestTip}
    |]