{- This file is part of funbot.
 -
 - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

-- For JSON field names and irc-fun-color StyledString
{-# LANGUAGE OverloadedStrings #-}

module FunBot.Memos
    ( submitMemo
    , reportMemos
    , reportMemosAll
    , loadBotMemos
    , mkSaveBotMemos
    )
where

import Control.Applicative ((<$>), (<*>))
import Control.Monad (liftM, mzero, unless)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson hiding (encode)
import Data.Aeson.Types (typeMismatch)
import Data.JsonState
import Data.List (partition)
import Data.Maybe (isJust)
import Data.Monoid ((<>))
import Data.Time.Units (Second)
import Formatting hiding (text)
import FunBot.Config (stateSaveInterval, configuration, memosFilename)
import FunBot.Settings.Instances
import FunBot.Types
import FunBot.Util ((!?), getTimeStr)
import Network.IRC.Fun.Bot.Chat (sendToChannel, sendToUser)
import Network.IRC.Fun.Bot.Nicks (channelIsTracked, isInChannel, presence)
import Network.IRC.Fun.Bot.State
import Network.IRC.Fun.Bot.Types (Config (cfgStateRepo))
import Network.IRC.Fun.Color
import Network.IRC.Fun.Types.Base

import qualified Data.HashMap.Lazy as M
import qualified Data.Text as T

-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------

getMemos :: BotSession (M.HashMap Nickname [Memo])
getMemos = getStateS bsMemos

putMemos :: M.HashMap Nickname [Memo] -> BotSession ()
putMemos ms = modifyState $ \ s -> s { bsMemos = ms }

modifyMemos :: (M.HashMap Nickname [Memo] -> M.HashMap Nickname [Memo])
            -> BotSession ()
modifyMemos f = modifyState $ \ s -> s { bsMemos = f $ bsMemos s }

-- | Get a list of the memos saved for a user, in the order they were sent.
getUserMemos :: Nickname
             -> BotSession [Memo]
getUserMemos recip = fmap (M.lookupDefault [] recip) getMemos

insertMemo :: Nickname -> Memo -> BotSession ()
insertMemo recip memo = do
    ms <- getMemos
    let oldList = M.lookupDefault [] recip ms
        newList = oldList ++ [memo]
    putMemos $ M.insert recip newList ms

-- | Set (override) a user's memo list to the given list, discarding the memos
-- previously stored there.
setUserMemos :: Nickname -> [Memo] -> BotSession ()
setUserMemos recip memos =
    modifyMemos $ if null memos then M.delete recip else M.insert recip memos

-- | Delete all memos for a given recipient, if any exist.
deleteUserMemos :: Nickname -> BotSession ()
deleteUserMemos recip = modifyMemos $ M.delete recip

-- | Prepare an IRC message which displays a memo.
formatMemo :: Maybe Nickname -- ^ Optional recipient nickname to mention
           -> Int               -- ^ Memo index to display
           -> Memo              -- ^ Memo to format
           -> MsgContent
formatMemo (Just recip) _idx memo =
    MsgContent $ sformat
        ( stext
        % ", "
        % stext
        % " said in "
        % stext
        % " UTC:\n“"
        % stext
        % "”"
        )
        (unNickname recip)
        (unNickname $ memoSender memo)
        (memoTime memo)
        (unMsgContent $ memoContent memo)
formatMemo Nothing idx memo =
    let n = Maroon #> plain (sformat ("[" % int % "]") idx)
        time = Purple #> plain (memoTime memo <> " UTC")
        sender = Gray #> "<" <> Green #> plain (unNickname $ memoSender memo) <> Gray #> ">"
        content = plain $ unMsgContent $ memoContent memo
    in  MsgContent $
        encode $ n <> " " <> time <> " " <> sender <> " " <> content

-- | Send a memo to its destination, nicely formatted.
sendMemo
    :: Nickname -- ^ Recipient nickname
    -> Int         -- ^ Memo index number for display (i.e. 1-based)
    -> Memo        -- ^ Memo to display on IRC
    -> BotSession ()
sendMemo recip idx memo =
    case memoSendIn memo of
        Just chan -> sendToChannel chan $ formatMemo (Just recip) idx memo
        Nothing   -> sendToUser recip $ formatMemo Nothing idx memo

-- | Send a memo to its destination, nicely formatted.
sendMemoList
    :: Nickname -- ^ Recipient nickname
    -> Int         -- ^ First memo's index number for display
    -> [Memo]      -- ^ Memos to display on IRC
    -> BotSession ()
sendMemoList recip idx ms =
    let send (i, m) = sendMemo recip i m
    in  mapM_ send $ zip [idx..] ms

-- | An instant memo response into the source channel or in PM.
sendInstant
    :: Nickname      -- ^ Sender nickname
    -> Maybe Channel -- ^ Source channel
    -> Nickname      -- ^ Recipient nickname
    -> MsgContent    -- ^ Message
    -> BotSession ()
sendInstant sender mchan recip content =
    case mchan of
        Just chan -> sendToChannel chan msg
        Nothing   -> sendToUser recip msg
    where
    msg = MsgContent $
        unNickname recip  <>
        ", "              <>
        unNickname sender <>
        " says: "         <>
        unMsgContent content

-- | Report to sender than their memo has been saved.
confirm
    :: Nickname       -- ^ Sender nickname
    -> Maybe Channel  -- ^ Whether sent 'Just' in channel or in PM.
    -> Nickname       -- ^ Recipient nickname
    -> BotSession ()
confirm sender (Just chan) recip = do
    sendToChannel chan $ MsgContent $ sformat
        ( stext
        % ", your memo for "
        % stext
        % " has been saved."
        )
        (unNickname sender)
        (unNickname recip)
    t <- channelIsTracked chan
    unless t $ sendToChannel chan $ MsgContent
        "Note that tracking of user joins and quits for this channel is \
        \currently disabled in bot settings."
confirm sender Nothing recip =
    sendToUser sender $ MsgContent $
        "Your memo for " <> unNickname recip <> " has been saved."

-------------------------------------------------------------------------------
-- Operations
-------------------------------------------------------------------------------

-- | Record a new memo for a given user.
addMemo
    :: Nickname      -- ^ Sender nickname
    -> Maybe Channel -- ^ Whether received in 'Just' a channel, or in PM
    -> Maybe Channel -- ^ Whether to send in 'Just' a channel, or in PM
    -> Nickname      -- ^ Recipient nickname
    -> MsgContent    -- ^ Memo content
    -> BotSession ()
addMemo sender recv send recip content = do
    time <- getTimeStr
    let memo = Memo
            { memoTime    = time
            , memoSender  = sender
            , memoRecvIn  = recv
            , memoSendIn  = send
            , memoContent = content
            }
    insertMemo recip memo

-- | Send a memo with the given index if exists. Return 'Nothing' on success,
-- or 'Just' the number of saved memos for the nickname on failure (invalid
-- index).
sendOneMemo :: Nickname -- ^ Recipient nickname
            -> Int         -- ^ Memo number, 0-based
            -> BotSession (Maybe Int)
sendOneMemo recip idx = do
    ms <- getMemos
    case M.lookup recip ms of
        Just l  -> case l !? idx of
            Just memo -> sendMemo recip (idx + 1) memo >> return Nothing
            Nothing   -> return $ Just $ length l
        Nothing -> return $ Just 0

-- | Delete a memo for a given recipient with the given index (position in the
-- memo list). On success, return 'Nothing'. On error, return 'Just' the number
-- of saved memos the receipient has.
deleteOneMemo
    :: Nickname -- ^ Recipient nickname
    -> Int         -- ^ Memo index number, 0-based
    -> BotSession (Maybe Int)
deleteOneMemo recip idx = do
    ms <- getMemos
    case M.lookup recip ms of
        Just l  -> case splitAt idx l of
            ([], _:[]) -> do
                putMemos $ M.delete recip ms
                return Nothing
            (b, _:a)   -> do
                putMemos $ M.insert recip (b ++ a) ms
                return Nothing
            _          -> return $ Just $ length l
        Nothing -> return $ Just 0

-------------------------------------------------------------------------------
-- Handlers
-------------------------------------------------------------------------------

-- | React to a user's request to make a new memo.
--
-- If user is online in same channel, send instantly to channel.
-- If user is online in another channel, send in PM (and report to sender).
-- If user not online, save memo and report to sender.
submitMemo
    :: Nickname
    -- ^ Sender nickname
    -> Maybe Channel
    -- ^ Whether sent in 'Just' a channel, or in PM
    -> Nickname
    -- ^ Recipient nickname
    -> Bool
    -- ^ Whether to always send memo privately (True) or the same as source
    -- (False)
    -> MsgContent
    -- ^ Memo content
    -> BotSession ()
submitMemo sender source recip private content = do
    let send = if private then Nothing else source
        instantToChan =
            case source of
                Just chan -> do
                    isin <- recip `isInChannel` chan
                    if isin
                        then do
                            sendInstant sender (Just chan) recip content
                            return True
                        else return False
                Nothing   -> return False
        instantToUser = do
            p <- presence recip
            if not $ null p
                then do
                    sendInstant sender Nothing recip content
                    return True
                else return False
        keepForLater = do
            addMemo sender source send recip content
            saveBotMemos
            confirm sender source recip
    succ1 <- instantToChan
    unless succ1 $ do
        succ2 <- instantToUser
        unless succ2 keepForLater

-- Send user memos. For a specific joined channel, or for all channels.
reportMemos'
    :: Nickname       -- ^ User nickname
    -> Maybe Channel -- ^ The channel the user joined
    -> BotSession ()
reportMemos' recip mchan = do
    ms <- getUserMemos recip
    let (msChan, msPriv) = partition (isJust . memoSendIn) ms
    (msChanSend, msChanOther) <- case mchan of
        Just chan ->
            let isThis Nothing        = False
                isThis (Just channel) = channel == chan
            in  return $ partition (isThis . memoSendIn) msChan
        Nothing -> do
            chans <- presence recip
            let isThese Nothing        = False
                isThese (Just channel) = channel `elem` chans
            return $ partition (isThese . memoSendIn) msChan
    unless (null msPriv) $ do
        let n = length msPriv
        sendToUser recip $ MsgContent $
            sformat ("Hello! You have " % int % " private memos:") n
        sendMemoList recip 1 msPriv
    sendMemoList recip 1 msChanSend
    unless (null msPriv && null msChanSend) $ do
        setUserMemos recip msChanOther
        saveBotMemos

-- | When a user logs in, use this to send them a report of the memos saved for
-- them, if any exist.
reportMemos
    :: Nickname -- ^ User nickname
    -> Channel -- ^ The channel the user joined triggering the report
    -> BotSession ()
reportMemos recip chan = reportMemos' recip (Just chan)

-- | Like 'reportMemos', but reports memos to all channels in which the user is
-- present.
reportMemosAll :: Nickname -> BotSession ()
reportMemosAll recip = reportMemos' recip Nothing

-------------------------------------------------------------------------------
-- Persistence
-------------------------------------------------------------------------------

instance FromJSON Memo where
    parseJSON (Object o) =
        Memo <$>
        o .: "time" <*>
        (Nickname <$> o .: "sender") <*>
        o .: "recv-in" <*>
        o .: "send-in" <*>
        (MsgContent <$> o .: "content")
    parseJSON v          = typeMismatch "Memo" v

instance ToJSON Memo where
    toJSON (Memo time sender recvIn sendIn content) = object
        [ "time"    .= time
        , "sender"  .= unNickname sender
        , "recv-in" .= recvIn
        , "send-in" .= sendIn
        , "content" .= unMsgContent content
        ]

loadBotMemos :: IO (M.HashMap Nickname [Memo])
loadBotMemos = do
    r <- loadState $ stateFilePath memosFilename (cfgStateRepo configuration)
    case r of
        Left (False, e) -> error $ "Failed to read memos file: " ++ e
        Left (True, e)  -> error $ "Failed to parse memos file: " ++ e
        Right s         -> return s

mkSaveBotMemos :: IO (M.HashMap Nickname [Memo] -> IO ())
mkSaveBotMemos =
    mkSaveStateChoose
        stateSaveInterval
        memosFilename
        (cfgStateRepo configuration)
        "auto commit by funbot"

saveBotMemos :: BotSession ()
saveBotMemos = do
    ms <- getStateS bsMemos
    save <- askEnvS saveMemos
    liftIO $ save ms