Memos.hs

{- This file is part of funbot.
 -
 - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
 -
 - ♡ 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 qualified Data.HashMap.Lazy as M
import Data.JsonState
import Data.List (partition)
import Data.Maybe (isJust)
import Data.Monoid ((<>))
import Data.Time.Units (Second)
import FunBot.Config (stateSaveInterval, configuration, memosFilename)
import FunBot.Types
import FunBot.Util ((!?))
import Network.IRC.Fun.Bot.Chat (sendToChannel, sendToUser)
import Network.IRC.Fun.Bot.Nicks (isInChannel, presence)
import Network.IRC.Fun.Bot.State
import Network.IRC.Fun.Bot.Types (Config (stateRepo))
import Network.IRC.Fun.Color
import Text.Printf (printf)

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

getMemos :: BotSession (M.HashMap String [Memo])
getMemos = getStateS memos

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

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

getTimeStr :: BotSession String
getTimeStr = do
    getTime <- askTimeGetter
    liftIO $ liftM snd getTime

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

insertMemo :: String -> 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 :: String -- ^ Recipient nickname
             -> [Memo] -- ^ New memo list to store
             -> 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 :: String -- ^ Recipient nickname
                -> BotSession ()
deleteUserMemos recip = modifyMemos $ M.delete recip

-- | Prepare an IRC message which displays a memo.
formatMemo :: Maybe String -- ^ Optional recipient nickname to mention
           -> Int          -- ^ Memo index to display
           -> Memo         -- ^ Memo to format
           -> String
formatMemo (Just recip) _idx memo =
    printf "%v, %v said in %v UTC:\n\"%v\""
        recip
        (memoSender memo)
        (memoTime memo)
        (memoContent memo)
formatMemo Nothing idx memo =
    let n = Maroon #> ("[" <> Pure (show idx) <> "]")
        time = Purple #> Pure (memoTime memo ++ " UTC")
        sender = Gray #> "<" <> Green #> Pure (memoSender memo) <> Gray #> ">"
        content = Pure $ memoContent memo
    in  encode $ n <> " " <> time <> " " <> sender <> " " <> content

-- | Send a memo to its destination, nicely formatted.
sendMemo :: String -- ^ 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 :: String -- ^ 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 :: String       -- ^ Sender nickname
            -> Maybe String -- ^ Source channel
            -> String       -- ^ Recipient nickname
            -> String       -- ^ Message
            -> BotSession ()
sendInstant sender mchan recip content =
    case mchan of
        Just chan -> sendToChannel chan msg
        Nothing   -> sendToUser recip msg
    where
    msg = printf "%v, %v says: %v" recip sender content

-- | Report to sender than their memo has been saved.
confirm :: String       -- ^ Sender nickname
        -> Maybe String -- ^ Whether sent 'Just' in channel or in PM.
        -> String       -- ^ Recipient nickname
        -> BotSession ()
confirm sender (Just chan) recip =
    sendToChannel chan $
    printf "%v, your memo for %v has been saved." sender recip
confirm sender Nothing recip =
    sendToUser sender $
    printf "Your memo for %v has been saved." recip

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

-- | Record a new memo for a given user.
addMemo :: String       -- ^ Sender nickname
        -> Maybe String -- ^ Whether received in 'Just' a channel, or in PM
        -> Maybe String -- ^ Whether to send in 'Just' a channel, or in PM
        -> String       -- ^ Recipient nickname
        -> String       -- ^ 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 :: String -- ^ 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 :: String -- ^ 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 :: String       -- ^ Sender nickname
           -> Maybe String -- ^ Whether sent in 'Just' a channel, or in PM
           -> String       -- ^ Recipient nickname
           -> Bool         -- ^ Whether to always send memo privately (True) or
                           --   the same as source (False)
           -> String       -- ^ 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 channels, or for all channels.
reportMemos' :: String       -- ^ User nickname
             -> Maybe String -- ^ 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 $ "Hello! You have " ++ show n ++ " private memos:"
        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 :: String -- ^ User nickname
            -> String -- ^ 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 :: String -- ^ User nickname
               -> BotSession ()
reportMemosAll recip = reportMemos' recip Nothing

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

instance FromJSON Memo where
    parseJSON (Object o) =
        Memo <$>
        o .: "time" <*>
        o .: "sender" <*>
        o .: "recv-in" <*>
        o .: "send-in" <*>
        o .: "content" {-<*>
        o .: "read"-}
    parseJSON _          = mzero

instance ToJSON Memo where
    toJSON (Memo time sender recvIn sendIn content {-rd-}) = object
        [ "time"    .= time
        , "sender"  .= sender
        , "recv-in" .= recvIn
        , "send-in" .= sendIn
        , "content" .= content
        --, "read"    .= rd
        ]

loadBotMemos :: IO (M.HashMap String [Memo])
loadBotMemos = do
    r <- loadState $ stateFilePath memosFilename (stateRepo 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 String [Memo] -> IO ())
mkSaveBotMemos =
    mkSaveStateChoose
        stateSaveInterval
        memosFilename
        (stateRepo configuration)
        "auto commit by funbot"

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