module Marvin.Adapter.IRC
( IRCAdapter, IRCChannel
) where
import Control.Concurrent.Async.Lifted
import Control.Concurrent.Chan.Lifted
import Control.Exception.Lifted
import Control.Lens
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Data.ByteString (ByteString)
import Data.Conduit
import Data.Maybe
import Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as L
import qualified Data.Text.Lazy.Encoding as L
import Data.Time.Clock (getCurrentTime)
import Marvin.Adapter
import Marvin.Interpolate.All
import Marvin.Types as MT
import Network.IRC.Conduit as IRC
type MarvinIRCMsg = IRC.Message L.Text
data IRCChannel
= RealChannel { chanName :: L.Text }
| Direct { chanName :: L.Text }
data IRCAdapter = IRCAdapter
{ msgOutChan :: Chan MarvinIRCMsg
}
producer :: Chan MarvinIRCMsg -> Producer IO IrcMessage
producer chan = forever $ do
msg <- readChan chan
yield $ T.encodeUtf8 . L.toStrict <$> msg
consumer = awaitForever . writeChan
processor :: Chan (Either ByteString IrcEvent) -> EventHandler IRCAdapter -> AdapterM IRCAdapter ()
processor inChan handler = do
IRCAdapter{msgOutChan} <- getAdapter
let handleOneMessage = readChan inChan >>= \case
Left bs -> logInfoN $(isT "Undecodable message: #{T.decodeUtf8 bs}")
Right rawEv -> do
let ev = fmap (L.fromStrict . T.decodeUtf8) rawEv
ts <- liftIO $ TimeStamp <$> getCurrentTime
let (user, channel) = case _source ev of
User nick -> (nick, Direct nick)
Channel chan user -> (user, RealChannel chan)
case _message ev of
Privmsg target (Right msg) -> do
botname <- getBotname
let (cmd, msg') = isMention botname target msg
runHandler $ cmd user channel msg' ts
Notice target (Right msg) -> do
botname <- getBotname
runHandler $ (if target == botname then CommandEvent else MessageEvent) user channel msg ts
Join channel' -> runHandler $ ChannelJoinEvent user (RealChannel channel') ts
Part channel' _ -> runHandler $ ChannelLeaveEvent user (RealChannel channel') ts
Kick channel' nick _ -> runHandler $ ChannelLeaveEvent nick (RealChannel channel') ts
Topic channel' t -> runHandler $ TopicChangeEvent user (RealChannel channel') t ts
Ping a b -> writeChan msgOutChan $ Pong $ fromMaybe a b
Invite chan _ -> writeChan msgOutChan $ Join chan
_ -> logDebugN $(isT "Unhandled event #{rawEv}")
forever $
handleOneMessage `catch` (\e -> logErrorN $(isT "UserError: #{e :: ErrorCall}"))
where
runHandler = void . async . liftIO . handler
isMention :: IsAdapter a
=> L.Text
-> L.Text
-> L.Text
-> (User a -> Channel a -> L.Text -> TimeStamp -> MT.Event a, L.Text)
isMention botname target msg
| L.head target /= '#' = (CommandEvent, msg)
| otherwise = case msg of
(L.stripPrefix (botname <> ", ") -> Just msg') -> (CommandEvent, L.stripStart msg')
(L.stripPrefix (botname <> ": ") -> Just msg') -> (CommandEvent, L.stripStart msg')
_ -> (MessageEvent, msg)
setUp :: Chan MarvinIRCMsg -> L.Text -> [L.Text] -> IO ()
setUp chan username channels = do
writeChan chan (Nick username)
writeChan chan (RawMsg $ "User " <> username <> " 0 * :" <> username)
writeList2Chan chan $ map Join channels
instance IsAdapter IRCAdapter where
type User IRCAdapter = L.Text
type Channel IRCAdapter = IRCChannel
adapterId = "irc"
messageChannel chan msg = do
IRCAdapter{msgOutChan} <- getAdapter
writeChan msgOutChan $ msgType $ Right msg
where
msgType = case chan of
Direct n -> Privmsg n
RealChannel c -> Notice c
getUsername = return
getChannelName = return . chanName
resolveChannel = return . Just . RealChannel
resolveUser = return . Just
initAdapter = IRCAdapter <$> newChan
runWithAdapter handler = do
port <- fromMaybe 7000 <$> lookupFromAdapterConfig "port"
host <- requireFromAdapterConfig "host"
user <- getBotname
channels <- requireFromAdapterConfig "channels"
IRCAdapter{msgOutChan} <- getAdapter
inChan <- newChan
a <- async $ processor inChan handler
link a
liftIO $ do
setUp msgOutChan user channels
ircClient port host (return ()) (consumer inChan) (producer msgOutChan)