summaryrefslogtreecommitdiff
path: root/Hsbot/Irc/Plugin/Quote.hs
blob: 0335d8b4991c06353464c5933239443f2d53c317 (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
module Hsbot.Irc.Plugin.Quote
    ( ircBotPluginQuote
    ) where

import Control.Concurrent.Chan
import Control.Exception
import Control.Monad.State
import qualified Data.Map as M
import Data.Maybe(fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.Time
import System.Directory
import IO hiding (catch)
import Prelude hiding (catch)
import System.FilePath
import System.Posix.Files
import System.Random(randomRIO)

import Hsbot.Irc.Message
import Hsbot.Irc.Plugin.Utils

-- | A quote element
data QuoteElt = QuoteElt
    { eltQuoter :: String
    , eltQuote  :: String
    } deriving (Read, Show)

-- | A quote object
data Quote = Quote
    { quoter    :: String
    , quote     :: [QuoteElt]
    , quoteTime :: UTCTime
    , votes     :: Int
    } deriving (Read, Show)

-- | A QuoteBot state
data QuoteBotState = QuoteBotState
    { nextQuoteId      :: Integer
    , quoteBotDB       :: M.Map Integer Quote
    , quotesInProgress :: M.Map Integer Quote
    } deriving (Read, Show)

-- | The QuoteBot monad
type QuoteBot a = StateT QuoteBotState (StateT IrcPluginState IO) a

-- | The plugin's main entry point
ircBotPluginQuote :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
ircBotPluginQuote myChan masterChan = do
    -- First of all we restore the database
    dir <- getAppUserDataDirectory "hsbot"
    let dbfile = dir </> "quotedb.txt"
    dbfileExists <- fileExist dbfile
    if not dbfileExists
      then
        let quoteBot = QuoteBotState 0 M.empty M.empty
        in TIO.writeFile dbfile (T.pack $ show quoteBot)
      else
        return ()
    txtQuoteBot <- TIO.readFile $ dbfile
    let quoteBot = read (T.unpack txtQuoteBot) :: QuoteBotState
    -- The plugin main loop
    let plugin = IrcPluginState { ircPluginName       = "Quote"
                                , ircPluginChan       = myChan
                                , ircPluginMasterChan = masterChan }
    evalStateT (mapM_ sendRegisterCommand ["quote"]) plugin
    _ <- (evalStateT (run quoteBot) plugin) `catch` (\(_ :: AsyncException) -> return quoteBot)
    evalStateT (mapM_ sendUnregisterCommand ["quote"]) plugin

-- | The IrcPlugin monad main function
run :: QuoteBotState -> IrcPlugin (QuoteBotState)
run quoteBot = do
    msg <- readMsg
    quoteBot' <- eval msg
    run quoteBot'
  where
    -- | evaluate what we just received
    eval :: IrcBotMsg -> IrcPlugin (QuoteBotState)
    eval (IntIrcCmd intCmd)
      | ircCmdCmd intCmd == "RUN" = do
          quoteBot' <- execStateT (runCommand intCmd) quoteBot
          return quoteBot'
      | otherwise = return quoteBot
    eval (InIrcMsg _) = return (quoteBot)
    eval (OutIrcMsg _) = return (quoteBot)

-- | run a command we received
runCommand :: IrcCmd -> QuoteBot ()
runCommand intCmd
  | theCommand == "quote" = runQuoteCommand
  | otherwise = return ()
  where
    -- | the message is a quote command
    runQuoteCommand :: QuoteBot ()
      | length args == 0 = do
          quoteDB <- gets quoteBotDB
          x <- liftIO $ randomRIO (0, (length $ M.keys quoteDB) - 1)
          if (length $ M.keys quoteDB) > 0
            then
              mapM_ (lift . answerMsg request) (formatQuote (M.keys quoteDB !! x) (M.elems quoteDB !! x))
            else
              lift $ answerMsg request "The quote database is empty."
      | otherwise = do
          dispatchQuoteCmd $ head args
    -- | quote command dispatcher
    dispatchQuoteCmd :: String -> QuoteBot ()
    dispatchQuoteCmd cmd
      | cmd == "start"  = do
          quoteBot <- get
          now <- liftIO $ getCurrentTime
          let sender   = takeWhile (/= '!') $ fromMaybe "ARGH" (ircMsgPrefix request)
              newQuote = Quote sender [(quoteElt stuff)] now 0
              quoteId     = nextQuoteId quoteBot
              quotesInProgress' = M.insert quoteId  newQuote (quotesInProgress quoteBot)
          put $ quoteBot { nextQuoteId = quoteId + 1, quotesInProgress = quotesInProgress' }
          lift $ answerMsg request ("New quoteId : " ++ show quoteId)
          syncQuoteBot
      | cmd == "append" = do
          quoteBot <- get
          case reads (head stuff) of
              [(quoteId :: Integer,"")] -> do
                  case M.lookup quoteId (quotesInProgress quoteBot) of
                      Just theQuote -> do
                          let newQuote = theQuote { quote = (quoteElt $ tail stuff) : (quote theQuote) }
                              quotesInProgress'  = M.insert quoteId newQuote (quotesInProgress quoteBot)
                          put $ quoteBot { quotesInProgress = quotesInProgress' }
                          syncQuoteBot
                      Nothing       -> lift $ answerMsg request ("quoteId not found : " ++ (show quoteId))
              _ -> lift $ answerMsg request ("Invalid quoteId : " ++ (head stuff))
      | cmd == "commit" = do
          quoteBot <- get
          case reads (head stuff) of
              [(quoteId :: Integer,"")] -> do
                  case M.lookup quoteId (quotesInProgress quoteBot) of
                      Just theQuote -> do
                          let quoteBotDB'       = M.insert quoteId theQuote (quoteBotDB quoteBot)
                              quotesInProgress' = M.delete quoteId (quotesInProgress quoteBot)
                          put $ quoteBot { quoteBotDB = quoteBotDB', quotesInProgress = quotesInProgress' }
                          syncQuoteBot
                      Nothing       -> lift $ answerMsg request ("quoteId not found : " ++ (show quoteId))
              _ -> lift $ answerMsg request ("Invalid quoteId : " ++ (head stuff))
      -- | cmd == "abort"  = 
      | otherwise = lift $ answerMsg request ("Invalid command : " ++ cmd)
    -- | Gets the new QuoteElt
    quoteElt :: [String] -> QuoteElt
    quoteElt msg = do
        let budy   = head $ msg
            theQuote  = unwords . tail $ msg
        QuoteElt budy theQuote
    -- | utilities
    params  = words . ircCmdMsg $ intCmd
    theCommand = head params
    args    = tail params
    stuff   = tail args
    request = ircCmdBotMsg intCmd

-- | The function that sync the quoteDB on disk
syncQuoteBot :: QuoteBot ()
syncQuoteBot = do
    dir <- liftIO $ getAppUserDataDirectory "hsbot"
    let dbfile = dir </> "quotedb.txt"
    file' <- liftIO $ openFile dbfile WriteMode
    quoteBot <- get
    liftIO . hPutStr file' $ show quoteBot
    liftIO $ hClose file'

formatQuote :: Integer -> Quote -> [String]
formatQuote quoteId theQuote =
    ("+---| " ++ (show quoteId) ++ " |-- Reported by " ++ (quoter theQuote) ++ " on " ++ (show $ quoteTime theQuote)) :
    foldl (\acc x -> formatQuoteElt x : acc) ["`------------------------------------------"] (quote theQuote)
  where
    formatQuoteElt :: QuoteElt -> String
    formatQuoteElt quoteElt = "| <" ++ (eltQuoter quoteElt) ++ "> " ++ (eltQuote quoteElt)