blob: 9cdeeaf19f71304d4380962de91e88b4c2b3ce81 (
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
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module Hirc.Bot where
import Prelude hiding (read)
import Network
import System.IO
import Control.Concurrent.STM
import Control.Monad.Reader
import Control.Exception
import Hirc.Parser as P
import Hirc.Types
import Text.Parsec (parse)
runBot :: Config -> Hooks -> IO ()
runBot Config{..} Hooks{..} =
bracket (connect config_server) disconnect run
where
connect Server{..} = do
socket <- connectTo hostname (PortNumber (fromIntegral port))
nick <- atomically $ newTVar config_nick
chan <- atomically $ newTVar config_chan
hSetBuffering socket NoBuffering
return Bot {
bot_server = config_server,
bot_nick = nick,
bot_chan = chan,
bot_socket = socket
}
disconnect bot@Bot{bot_socket=h} = do
hClose h
runReaderT hooks_onDisconnect bot
run bot = do
runReaderT (hooks_onConnect >> receive hooks_onMessage hooks_onError) bot
receive :: (Message -> Net ()) -> (Error -> Net ()) -> Net ()
receive onMessage onError = do
server <- asks bot_server
socket <- asks bot_socket
forever $ do
s <- init <$> liftIO (hGetLine socket)
case parse P.message (show server) s of
Right m -> do
case m of
Message _ "PING" [x] -> do
h <- asks bot_socket
liftIO $ hPutStr h $ "PONG :" ++ x ++ "\r\n"
_ -> return ()
onMessage m
e -> onError $ BadMessage $ show e -- TODO
atomic :: (Bot -> a) -> (a -> STM b) -> Net b
atomic v f = asks v >>= liftIO . atomically . f
read :: (Bot -> TVar a) -> Net a
read v = atomic v readTVar
write :: (Bot -> TVar a) -> a -> Net ()
write v = atomic v . flip writeTVar
bumpNick :: Net String
bumpNick =
atomic bot_nick $ flip updateTVar $ \nick ->
case parse P.nickNum "bumpNick" nick of
Right (n,i) -> n ++ show (i+1)
_ -> nick ++ "_"
-- Like modifyTVar but returns the new value.
updateTVar :: TVar a -> (a -> a) -> STM a
updateTVar v f = do
x <- readTVar v
let x' = f x
writeTVar v x'
return x'
|
