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
|
{-# LANGUAGE TypeFamilies, DeriveDataTypeable, TemplateHaskell #-}
-- | This module is an IRC plugin that manages quotes for posterity and legend
module Hsbot.Plugin.Quote
-- ( quote
-- , theQuote
() where
import Control.Monad.Reader
import Control.Monad.State
import Data.Acid
import qualified Data.Map as M
import qualified Network.IRC as IRC
import System.Random
import Data.SafeCopy
import Data.Typeable
import System.Time
import Hsbot.Message
import Hsbot.Types
import Hsbot.Utils
-- | 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
, quote :: [QuoteElt]
, quoteTime :: ClockTime
, votes :: Int
, voters :: M.Map IRC.UserName QuoteID
} deriving (Show, Typeable)
emptyQuote :: Quote
emptyQuote = Quote { quoter = ""
, quote = []
, quoteTime = TOD 0 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, ClockTime)
, lastActive :: M.Map IRC.Channel QuoteID
} deriving (Show, Typeable)
emptyQuoteDB :: QuoteDB
emptyQuoteDB = QuoteDB { nextQuoteId = 0
, quoteBotDB = M.empty
, lockedQuotes = M.empty
, lastActive = Nothing }
$(deriveSafeCopy 0 'base ''QuoteElt)
$(deriveSafeCopy 0 'base ''Quote)
$(deriveSafeCopy 0 'base ''QuoteDB)
-- | Quote database transactions
getQuote :: QuoteID -> Query QuoteDB (Maybe Quote)
getQuote quoteId = asks quoteBotDB >>= return . M.lookup quoteId
getQuoteDB :: Query QuoteDB (M.Map QuoteID Quote)
getQuoteDB = asks quoteBotDB
-- TODO : a function for cleaning locks
isQuoteLockedFor :: QuoteID -> IRC.UserName -> ClockTime -> Query QuoteDB (Either String Bool)
isQuoteLockedFor quoteId requestor now = do
theQuote <- asks quoteBotDB >>= return . M.lookup quoteId
case theQuote of
Just quote -> do
currentLock <- asks lockedQuotes >>= return . M.lookup quoteId
case currentLock of
Just (owner, lockStamp) ->
if owner == requestor
then return $ Right True
else return . Right $ (addToClockTime (TimeDiff 0 0 0 0 5 0 0) lockStamp > now) -- Is the entry older than 5 min?
Nothing -> return $ Right True
Nothing -> return $ Left "QuoteId not found"
lockQuoteIdFor :: QuoteID -> IRC.UserName -> ClockTime -> Update QuoteDB ()
lockQuoteIdFor quoteId requestor now = get >>= \db -> put db { lockedQuotes = M.insert quoteId (requestor, now) (lockedQuotes db) }
$(makeAcidic ''QuoteDB ['getQuote, 'getQuoteDB, 'isQuoteLockedFor, 'lockQuoteIdFor])
-- | gets a random quote from the database
getRandomQuote :: AcidState QuoteDB -> IO (Maybe Quote)
getRandomQuote quoteDB = do
db <- query' quoteDB GetQuoteDB
if M.size db > 0
then getStdRandom (randomR (0, M.size db - 1)) >>= \rInt -> return . Just . snd $ M.elemAt rInt db
else return Nothing
-- | The duck plugin identity
quote :: PluginId
quote = PluginId
{ pluginName = "quote"
, pluginEp = theQuote }
-- | An IRC plugin that generates and kills ducks
theQuote :: Plugin (Env IO) () -- TODO : an argument for the history size
theQuote = do
baseDir <- liftIO $ System.Environment.XDG.BaseDir.getUserDataDir "hsbot"
statDB <- liftIO $ openAcidStateFrom (baseDir ++ "/quoteDB/") 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":"help":"append":_ -> answerMsg "quote append QUOTEID QUOTEE QUOTE"
"quote":"help":"delete":_ -> do
answerMsg "quote delete QUOTEID [ELTID] :"
answerMsg $ concat [ " If an ELTID is provided, deletes the ELTID's line (starting from zero) "
, "in the quote QUOTEID. If not the whole quote is deleted." ]
"quote":"help":"quick":_ -> do
answerMsg "quote [quick] QUOTEE [QUOTE] :"
answerMsg $ concat [ " Begins a quote for QUOTEE. You must provide the keywork quick 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 "quote show { QUOTEID | random [MIN_SCORE] }"
"quote":"help":"stat":_ -> do
answerMsg "quote stat"
answerMsg " Compute statistics about the quote database : Most quoters, most quoted "
"quote":"help":[] -> do
answerMsg $ concat [ "Usage: quote { [quick] QUOTEE [QUOTE] | append QUOTEID QUOTEE QUOTE | "
, "delete QUOTEID [ELTID] | show { QUOTEID | random [MIN_SCORE] } | stat }" ]
"quote":"help":_ -> answerMsg "Invalid help topic."
"quote":_ -> answerMsg msg "Invalid quote command."
"vote":"help":"quick":_ -> do
answerMsg "vote [quick] [QUOTEID] { +1 | -1 | ++ | -- }"
answerMsg $ concat [ " 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 $ concat [ "Usage: vote { [quick] [QUOTEID] { +1 | -1 } | show [QUOTEID] | stat }"
"vote":"help":_ -> answerMsg "Invalid help topic."
"vote":_ -> answerMsg msg "Invalid vote command."
_ -> return ()
| otherwise = return ()
eval _ _ _ _ = return ()
|
