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
    , loadBotMemos
    , mkSaveBotMemos
    --, saveBotMemos
    )
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.Monoid ((<>))
import Data.Settings.Persist
import Data.Time.Units (Second)
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.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

-- | 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
           -> String       -- ^ Memo content
           -> BotSession ()
submitMemo sender source recip content = do
    let 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 Nothing recip content
            saveBotMemos
            confirm sender source recip
    succ1 <- instantToChan
    unless succ1 $ do
        succ2 <- instantToUser
        unless succ2 keepForLater

-- | 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
            -> BotSession ()
reportMemos recip = do
    ms <- getUserMemos recip
    unless (null ms) $ do
        sendToUser recip $ "You have " ++ show (length ms) ++ " memos:"
        sendMemoList recip 1 ms
        deleteUserMemos recip
        saveBotMemos

-------------------------------------------------------------------------------
-- 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
        ]

memosFilename = "state/memos.json"

saveInterval = 3 :: Second

loadBotMemos :: IO (M.HashMap String [Memo])
loadBotMemos = do
    r <- loadSettings memosFilename
    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 = mkSaveSettings saveInterval memosFilename

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