summaryrefslogtreecommitdiff
path: root/Hsbot/Plugin/Quote.hs
blob: a61c343141296befc840bf6e19d9c5592c86874d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
{-# LANGUAGE TypeFamilies, DeriveDataTypeable, TemplateHaskell #-}
-- | This module is an IRC plugin that manages quotes for posterity and legend
module Hsbot.Plugin.Quote
    ( QuoteArgs (..)
    , quote
    , theQuote
    ) where

import Control.Monad.Reader
import Control.Monad.State
import Data.Acid
import qualified Data.Map as M
import Data.Maybe
import Data.SafeCopy
import Data.Time
import Data.Time.Clock.POSIX
import Data.Typeable
import qualified Network.IRC as IRC
import System.Environment.XDG.BaseDir
import System.Random

import Hsbot.Message
import Hsbot.Types

-- | A quote element
data QuoteElt = QuoteElt
    { eltQuotee :: IRC.UserName
    , eltQuote  :: String
    } deriving (Show, Typeable)

type QuoteID = Int

-- | A quote object
data Quote = Quote
    { quoter    :: IRC.UserName
    , quoteFrom :: IRC.Channel
    , quotE     :: [QuoteElt]
    , quoteTime :: UTCTime
    , votes     :: Int
    , voters    :: M.Map IRC.UserName QuoteID
    } deriving (Show, Typeable)

emptyQuote :: Quote
emptyQuote = Quote { quoter = ""
                   , quoteFrom = ""
                   , quotE = []
                   , quoteTime = posixSecondsToUTCTime 0
                   , votes = 0
                   , voters = M.empty }

-- The Quote database
data QuoteDB = QuoteDB
    { nextQuoteId  :: QuoteID
    , quoteBotDB   :: M.Map QuoteID Quote
    , lockedQuotes :: M.Map QuoteID (IRC.UserName, UTCTime)
    , lastActive   :: M.Map IRC.Channel QuoteID
    } deriving (Show, Typeable)

emptyQuoteDB :: QuoteDB
emptyQuoteDB = QuoteDB { nextQuoteId  = 0
                       , quoteBotDB   = M.empty
                       , lockedQuotes = M.empty
                       , lastActive   = M.empty }

$(deriveSafeCopy 0 'base ''QuoteElt)
$(deriveSafeCopy 0 'base ''Quote)
$(deriveSafeCopy 0 'base ''QuoteDB)

-- | Quote database transactions
getQuote :: QuoteID -> Query QuoteDB (Maybe Quote)
getQuote quoteId = fmap (M.lookup quoteId) (asks quoteBotDB)

getQuoteDB :: Query QuoteDB (M.Map QuoteID Quote)
getQuoteDB = asks quoteBotDB

-- TODO : a function for cleaning locks

isQuoteLockedFor :: QuoteID -> IRC.UserName -> UTCTime -> Query QuoteDB (Maybe Bool)
isQuoteLockedFor quoteId requestor now = do
    theQuote <- fmap (M.lookup quoteId) (asks quoteBotDB)
    case theQuote of
        Just _ -> do
            currentLock <- fmap (M.lookup quoteId) (asks lockedQuotes)
            case currentLock of
                Just (owner, lockStamp) ->
                  if owner == requestor
                    then return $ Just True
                    else return . Just $ (addUTCTime 300 lockStamp < now)     -- Is the entry older than 5 min?
                Nothing -> return $ Just True
        Nothing -> return Nothing

lockQuoteIdFor :: QuoteID -> IRC.UserName -> IRC.Channel -> UTCTime -> Update QuoteDB ()
lockQuoteIdFor quoteId requestor channel now = get >>= \db -> put db { lockedQuotes = M.insert quoteId (requestor, now) (lockedQuotes db)
                                                                     , lastActive = M.insert channel quoteId (lastActive db) }

deleteQuote :: QuoteID -> IRC.Channel -> Update QuoteDB ()
deleteQuote quoteId channel = get >>= \db -> put db { quoteBotDB = M.delete quoteId (quoteBotDB db)
                                                    , lockedQuotes = M.delete quoteId (lockedQuotes db)
                                                    , lastActive = M.delete channel (lastActive db) }

setQuote :: QuoteID -> Quote -> Update QuoteDB ()
setQuote quoteId theQuote = get >>= \db -> put db { quoteBotDB = M.insert quoteId theQuote (quoteBotDB db) }

getLastActiveQuote :: IRC.Channel -> Query QuoteDB (Maybe QuoteID)
getLastActiveQuote channel = fmap (M.lookup channel) (asks lastActive)

setLastActiveQuote :: IRC.Channel -> QuoteID -> Update QuoteDB ()
setLastActiveQuote channel quoteID = get >>= \db -> put db { lastActive = M.insert channel quoteID (lastActive db) }

takeNextQuoteID :: IRC.UserName -> IRC.Channel -> UTCTime -> Update QuoteDB QuoteID
takeNextQuoteID requestor channel now = do
    db <- get
    let quoteId = nextQuoteId db
    put db { nextQuoteId = nextQuoteId db + 1
           , lockedQuotes = M.insert quoteId (requestor, now) (lockedQuotes db)
           , lastActive = M.insert channel quoteId (lastActive db) }
    return quoteId

$(makeAcidic ''QuoteDB [ 'getQuote, 'getQuoteDB, 'isQuoteLockedFor, 'lockQuoteIdFor, 'deleteQuote, 'setQuote
                       , 'getLastActiveQuote, 'setLastActiveQuote, 'takeNextQuoteID ])

-- | gets a random quote from the database
getRandomQuote :: AcidState QuoteDB -> IO (Maybe (Quote, QuoteID))
getRandomQuote quoteDB = do
    db <- liftIO $ query quoteDB GetQuoteDB
    if M.size db > 0
      then getStdRandom (randomR (0, M.size db - 1)) >>= \rInt -> return $ Just (snd (M.elemAt rInt db), rInt)
      else return Nothing

-- | The quote plugin identity
quote :: PluginId
quote = PluginId
    { pluginName = "quote"
    , pluginEp   = theQuote QuoteArgs { quoteDbName = "quoteDB" } }

data QuoteArgs = QuoteArgs
    { quoteDbName :: String }

-- | An IRC plugin that handle quotes
theQuote :: QuoteArgs -> Plugin (Env IO) ()  -- TODO : an argument for the history size
theQuote (QuoteArgs dbName) = do
    baseDir <- liftIO $ System.Environment.XDG.BaseDir.getUserDataDir "hsbot"
    quoteDB <- liftIO $ openLocalStateFrom (baseDir ++ "/" ++ dbName ++ "/") emptyQuoteDB
    forever $ readMsg >>= eval quoteDB
  where
    eval :: AcidState QuoteDB -> Message -> Plugin (Env IO) ()
    eval quoteDB (IncomingMsg msg)
        | IRC.msg_command msg == "PRIVMSG" = do
            cmdArgs <- lift $ getCommand msg
            case cmdArgs of
                "quote":"append":quoteID:quotee:quoteTxt ->
                    case reads quoteID :: [(Int, String)] of
                        (qid,_):_ -> quoteAppend quoteDB msg qid quotee $ unwords quoteTxt
                        _ -> do
                            let quotee' = quoteID
                                quoteTxt' = quotee : quoteTxt
                            lastQid <- liftIO . query quoteDB $ GetLastActiveQuote (getChannel msg)
                            case lastQid of
                                Just qid -> quoteAppend quoteDB msg qid quotee' $ unwords quoteTxt'
                                Nothing -> answerMsg msg $ getSender msg ++ " : Invalid quoteID."
                "quote":"delete":quoteID:eltID ->
                    case reads quoteID :: [(Int, String)] of
                        (qid,_):_ -> case eltID of
                            [] -> quoteDelete quoteDB msg qid
                            eltID':[] -> case reads eltID' :: [(Int, String)] of
                                (eltid,_):_ -> quoteDeleteElt quoteDB msg qid eltid
                                _ -> answerMsg msg $ getSender msg ++ ": Invalid elementID."
                            _ -> answerMsg msg $ getSender msg ++ ": Invalid elementID."
                        _ -> answerMsg msg $ getSender msg ++ " : Invalid quoteID."
                "quote":"help":"append":_ -> answerMsg msg $ "quote append [QUOTEID] QUOTEE QUOTE"
                                             ++ "If no QUOTEID is provided, tries to append to the last active quote."
                "quote":"help":"delete":_ -> do
                    answerMsg msg "quote delete QUOTEID [ELTID] :"
                    answerMsg msg $ "  If an ELTID is provided, deletes the ELTID's line in the quote QUOTEID. "
                                 ++ "If not the whole quote is deleted."
                "quote":"help":"start":_ -> do
                    answerMsg msg "quote [start] QUOTEE [QUOTE] :"
                    answerMsg msg $ "  Begins a quote for QUOTEE. You must provide the keywork start if the "
                                 ++ "QUOTEE's nickname is a reserved word for this quote module. If no QUOTE is "
                                 ++ "provided this module lookup it's conversation history and records the "
                                 ++ "last sentence of QUOTEE."
                "quote":"help":"show":_ -> answerMsg msg "quote show { QUOTEID | [random] }"
                "quote":"help":"stat":_ -> do
                    answerMsg msg "quote stat"
                    answerMsg msg "  Compute statistics about the quote database : Most quoters, most quoted "
                "quote":"help":[] ->
                    answerMsg msg $ "Usage: quote { [start] QUOTEE [QUOTE] | append [QUOTEID] QUOTEE QUOTE | "
                                 ++ "delete QUOTEID [ELTID] | show { QUOTEID | random [MIN_SCORE] } | stat }"
                "quote":"help":_ -> answerMsg msg "Invalid help topic."
                "quote":"show":"random":[] -> showRandomQuote
                "quote":"show":quoteID:[] ->
                    case reads quoteID :: [(Int, String)] of
                        (qid,_):_ -> do
                            thisQuote <- liftIO . query quoteDB $ GetQuote qid
                            case thisQuote of
                                Just this -> quoteShow quoteDB msg qid this
                                Nothing -> answerMsg msg $ getSender msg ++ ": Invalid quoteID or empty database."
                        _ -> answerMsg msg $ getSender msg ++ " : Invalid quoteID."
                "quote":"show":[] -> showRandomQuote
                "quote":"start":quotee:phrase -> quoteStart quoteDB msg quotee $ unwords phrase
                "quote":quotee:phrase -> quoteStart quoteDB msg quotee $ unwords phrase
                "quote":_ -> answerMsg msg "Invalid quote command."
                "vote":"help":"quick":_ -> do
                    answerMsg msg "vote [quick] [QUOTEID] { +1 | -1 | ++ | -- }"
                    answerMsg msg $ "  Vote for a quote. You can also vote for the last active quote on this chan "
                                 ++ "by typing something that begins by +1, -1 or ++ or --."
                "vote":"help":[] -> answerMsg msg "Usage: vote { [quick] [QUOTEID] { +1 | -1 } | show [QUOTEID] | stat }"
                "vote":"help":_ -> answerMsg msg "Invalid help topic."
                "vote":_ -> answerMsg msg "Invalid vote command."
                _ -> return ()
        | otherwise = return ()
      where
        showRandomQuote :: Plugin (Env IO) ()
        showRandomQuote = do
            rquote <- liftIO (getRandomQuote quoteDB)
            case rquote of
                Just (that, qid) -> quoteShow quoteDB msg qid that
                Nothing -> answerMsg msg $ getSender msg ++ ": the quote database is empty."
    eval _ _ = return ()

quoteAppend :: AcidState QuoteDB -> IRC.Message -> QuoteID -> IRC.UserName -> String -> Plugin (Env IO) ()
quoteAppend quoteDB msg quoteID quotee text = do
    now <- liftIO getCurrentTime
    activeLock <- liftIO . query quoteDB $ IsQuoteLockedFor quoteID sender now
    case activeLock of
        Just True -> do
            _ <- liftIO . update quoteDB $ LockQuoteIdFor quoteID sender channel now
            mQuote <- liftIO . query quoteDB $ GetQuote quoteID
            let newQuote = fromMaybe emptyQuote mQuote
                newQuote' = newQuote { quotE = quotE newQuote ++ [ QuoteElt { eltQuotee = quotee, eltQuote = text } ] }
            _ <- liftIO . update quoteDB $ SetQuote quoteID newQuote'
            answerMsg msg $ sender ++ ": Appended to quote " ++ show quoteID ++ "."
        Just False -> answerMsg msg $ sender ++ ": Someone else is editing this quote right now."
        Nothing -> answerMsg msg $ sender ++ ":quoteId not found."
  where
    sender = getSender msg
    channel = getChannel msg

quoteDelete :: AcidState QuoteDB -> IRC.Message -> QuoteID -> Plugin (Env IO) ()
quoteDelete quoteDB msg quoteID = do
    now <- liftIO getCurrentTime
    activeLock <- liftIO . query quoteDB $ IsQuoteLockedFor quoteID sender now
    case activeLock of
        Just True -> do
            _ <- liftIO . update quoteDB $ DeleteQuote quoteID channel
            answerMsg msg $ sender ++ ": deleted quote " ++ show quoteID ++ "."
        Just False -> answerMsg msg $ sender ++ ": Someone else is editing this quote right now."
        Nothing -> answerMsg msg $ sender ++ ":quoteId not found."
  where
    sender = getSender msg
    channel = getChannel msg

quoteDeleteElt :: AcidState QuoteDB -> IRC.Message -> QuoteID -> Int -> Plugin (Env IO) ()
quoteDeleteElt quoteDB msg quoteID eltID = do
    now <- liftIO getCurrentTime
    activeLock <- liftIO . query quoteDB $ IsQuoteLockedFor quoteID sender now
    case activeLock of
        Just True -> do
            _ <- liftIO . update quoteDB $ LockQuoteIdFor quoteID sender channel now
            mQuote <- liftIO . query quoteDB $ GetQuote quoteID
            let newQuote = fromMaybe emptyQuote mQuote
                newQuote' = newQuote { quotE = getRidOfEltFrom (quotE newQuote) }
            _ <- liftIO . update quoteDB $ SetQuote quoteID newQuote'
            answerMsg msg $ sender ++ ": deleted element number " ++ show eltID ++ " from quote " ++ show quoteID ++ "."
        Just False -> answerMsg msg $ sender ++ ": Someone else is editing this quote right now."
        Nothing -> answerMsg msg $ sender ++ ": quoteId not found."
  where
    sender = getSender msg
    channel = getChannel msg
    getRidOfEltFrom :: [QuoteElt] -> [QuoteElt]
    getRidOfEltFrom elts
      | eltID <= 0 = elts
      | eltID > length elts = elts
      | otherwise = let (l, r) = splitAt (eltID -1) elts
                    in l ++ tail r

quoteShow :: AcidState QuoteDB -> IRC.Message -> QuoteID -> Quote -> Plugin (Env IO) ()
quoteShow quoteDB msg quoteID thatQuote = do
    mapM_ (answerMsg msg) formatQuote
    liftIO . update quoteDB $ SetLastActiveQuote channel quoteID
  where
    channel = getChannel msg
    formatQuote :: [String]
    formatQuote = ("+-- [" ++ show quoteID ++ "] --- Reported by " ++ quoter thatQuote ++ " on " ++ quoteFrom thatQuote)
               : map formatElt (quotE thatQuote)
               ++ [ "+-- Added on " ++ show (quoteTime thatQuote) ++ " --- Score : " ++ show (votes thatQuote) ]
    formatElt :: QuoteElt -> String
    formatElt this = "| " ++ eltQuotee this ++ ": " ++ eltQuote this

quoteStart :: AcidState QuoteDB -> IRC.Message -> IRC.UserName -> String -> Plugin (Env IO) ()
quoteStart quoteDB msg quotee phrase =
    case phrase of
      [] -> answerMsg msg "TODO: implement history lookup"
      that -> quoteThat that
  where
    sender = getSender msg
    channel = getChannel msg
    quoteThat :: String -> Plugin (Env IO) ()
    quoteThat thatQuote = do
        now <- liftIO getCurrentTime
        quoteID <- liftIO . update quoteDB $ TakeNextQuoteID sender channel now
        let newQuote = emptyQuote { quoter = sender
                                  , quoteFrom = channel
                                  , quotE = [ QuoteElt { eltQuotee = quotee, eltQuote = thatQuote } ]
                                  , quoteTime = now }
        _ <- liftIO . update quoteDB $ SetQuote quoteID newQuote
        answerMsg msg $ sender ++ ": new quote added with ID " ++ show quoteID