Skip to content

Instantly share code, notes, and snippets.

@slaykovsky slaykovsky/main.hs
Created Apr 10, 2018

Embed
What would you like to do?
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Main where
import Control.Arrow
import Control.Concurrent
import Control.Exception
import Control.Monad.Reader
import Data.Either
import Data.List
import Data.Time.Clock
import Database.MongoDB ((=:))
import Database.MongoDB
import Network
import System.Exit
import System.IO
import Text.Parsec
import Text.Printf
import Config
import IrcCommand
import Parser
type Net = ReaderT Bot IO
data Bot = Bot
{ socket :: Handle
, config :: Config
, pipe :: Pipe
}
main :: IO ()
main = bracket connectBot disconnect loop
where
disconnect = hClose . socket >> close . pipe
loop st = runReaderT run st
connectBot :: IO Bot
connectBot =
notify $ do
c <- readConfig
h <- connectTo (server c) (PortNumber . fromIntegral . port $ c)
p <- connect $ host "127.0.01"
hSetBuffering h NoBuffering
hSetEncoding h utf8
return $ Bot h c p
where
server = scAddress . cServer
port = scPort . cServer
notify a =
bracket_ (printf "Connecting..." >> hFlush stdout) (putStrLn "done.") a
getMessage :: String -> Net IrcMessage
getMessage s =
let message l =
case (parse parseMessage "ircMessage" l) of
Left _ -> error "Failed to parse"
Right x -> x
in do return $ message s
run :: Net ()
run = do
c <- asks config
h <- asks socket
p <- asks pipe
writeNick $ nick c
writeUser $ user c
forM_ (channels c) joinChan >> listen h p
where
writeNick = write "NICK"
writeUser = write "USER"
joinChan = write "JOIN"
nick = cNickname
user c = nick c ++ " 0 * :" ++ nick c
channels = scChannels . cServer
makeFields :: IrcMessage -> Net Document
makeFields m = do
p <- pure $ makeParameters (getParameters m)
message <- case p of
Right m -> pure $ m
Left _ -> pure $ ""
time <- lift getCurrentTime
return $ [ "time" =: time
, "message" =: message
]
insertMessage :: Pipe -> Document -> Net ()
insertMessage p m = do
e <- access p master "lor" (insert_ "messages" m)
return e
listen :: Handle -> Pipe -> Net ()
listen h p =
forever $ do
s <- init `fmap` io (hGetLine h)
io $ printf "%s" s
message <- getMessage s
document <- makeFields message
io . putStrLn $ s
io . putStrLn . show $ message
if ping s
then pong s
else insertMessage p document
where
ping x = "PING :" `isPrefixOf` x
pong x = write "PONG" (':' : drop 6 x)
forever x = forever x >> forever x
write :: String -> String -> Net ()
write s t = do
h <- asks socket
io $ hPrintf h "%s %s\r\n" s t
io $ printf "> %s %s\n" s t
io :: IO a -> Net a
io = liftIO
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.