253 lines
No EOL
7 KiB
Haskell
253 lines
No EOL
7 KiB
Haskell
import Network
|
|
import System.IO
|
|
import Text.Printf
|
|
import Data.List
|
|
import Data.Char
|
|
import System.Exit
|
|
import Control.Monad.State
|
|
import Text.Regex.Posix
|
|
import Data.Char (isSpace)
|
|
|
|
server = "irc.epd-me.net"
|
|
port = 6667
|
|
chan = "#selfhtml"
|
|
nick = "anna"
|
|
rname = "Boten Anna"
|
|
|
|
type Nick = String
|
|
data Type = Kick | Invite | Privmsg | Unknown
|
|
deriving (Show)
|
|
|
|
type Text = String
|
|
data Message = Message Nick Type Text
|
|
deriving (Show)
|
|
|
|
type Key = String
|
|
type Value = String
|
|
type Store = [(Key, Value)]
|
|
|
|
type MyState = (Store, Handle)
|
|
type MyStateM = StateT MyState IO
|
|
|
|
main :: IO ()
|
|
main = do
|
|
h <- connectTo server (PortNumber (fromIntegral port))
|
|
hSetBuffering h NoBuffering
|
|
let state = (startStore, h)
|
|
runStateT (login >> listen) state >> return ()
|
|
|
|
login :: MyStateM ()
|
|
login = do
|
|
write "NICK" nick
|
|
write "USER" (nick ++ " 0 * :" ++ rname)
|
|
joinChan
|
|
return ()
|
|
|
|
joinChan :: MyStateM ()
|
|
joinChan = do
|
|
write "JOIN" chan
|
|
|
|
getHandle :: MyStateM (Handle)
|
|
getHandle = do
|
|
(_, h) <- get
|
|
return h
|
|
|
|
putHandle :: Handle -> MyStateM ()
|
|
putHandle h = do
|
|
(s, _) <- get
|
|
put (s, h)
|
|
return ()
|
|
|
|
getStore :: MyStateM (Store)
|
|
getStore = do
|
|
(s, _) <- get
|
|
return s
|
|
|
|
putStore :: Store -> MyStateM ()
|
|
putStore s = do
|
|
(_, h) <- get
|
|
put (s, h)
|
|
return ()
|
|
|
|
putKeyValue :: String -> String -> MyStateM ()
|
|
putKeyValue k v = do
|
|
s <- getStore
|
|
putStore (s ++ [(k,v)])
|
|
return ()
|
|
|
|
deleteKeyValue :: String -> MyStateM ()
|
|
deleteKeyValue key = do
|
|
s <- getStore
|
|
let sn = [(k,v) | (k,v) <- s, k /= key]
|
|
putStore (sn)
|
|
|
|
match :: String -> MyStateM (Maybe Value)
|
|
match s = do
|
|
st <- getStore
|
|
case (find (\(key, value) -> s =~ key) st) of
|
|
Nothing -> return Nothing
|
|
Just (k,v) -> return (Just v)
|
|
|
|
write :: String -> String -> MyStateM ()
|
|
write s t = do
|
|
h <- getHandle
|
|
liftIO $ hPrintf h "%s %s\r\n" s t
|
|
|
|
listen :: MyStateM ()
|
|
listen = forever $ do
|
|
h <- getHandle
|
|
t <- liftIO $ hGetLine h
|
|
let s = init t
|
|
if ping s
|
|
then pong s
|
|
else do eval (parse s)
|
|
-- liftIO $ putStrLn s
|
|
return ()
|
|
where
|
|
forever a = a >> forever a
|
|
clean = drop 1 . dropWhile (/= ':') . drop 1
|
|
ping x = "PING :" `isPrefixOf` x
|
|
pong x = write "PONG" (':' : drop 6 x)
|
|
|
|
eval :: Maybe Message -> MyStateM ()
|
|
eval (Just m@(Message n Privmsg te)) = evalPrivmsg (Just m)
|
|
eval (Just (Message _ Invite _)) = invited
|
|
eval _ = return ()
|
|
|
|
evalPrivmsg :: Maybe Message -> MyStateM ()
|
|
evalPrivmsg Nothing = return ()
|
|
evalPrivmsg (Just m@(Message n _ te)) = do
|
|
let pat = nick ++ ":(.*)"
|
|
let r = te =~ pat :: [[String]]
|
|
case r of
|
|
[] -> do m <- Main.match te
|
|
case m of
|
|
Just v -> privmsg v
|
|
Nothing -> return ()
|
|
a -> do let s = last $ head a
|
|
action (trim s) m
|
|
return ()
|
|
|
|
action :: String -> Message -> MyStateM ()
|
|
action s (Message n _ _) | "add " `isPrefixOf` s = do
|
|
let (k,v) = parseKeyVal $ rest "add" s
|
|
putKeyValue k v
|
|
msg (k ++ "~" ++ v ++ " added") n
|
|
return ()
|
|
action s (Message n _ _) | "delete " `isPrefixOf` s = do
|
|
let k = rest "delete" s
|
|
deleteKeyValue k
|
|
msg (k ++ " deleted") n
|
|
return ()
|
|
action "list" (Message n _ _) = do
|
|
st <- getStore
|
|
mapM (\(k,v) -> msg (k ++ "~" ++ v) n) st
|
|
return ()
|
|
action "leave" (Message n _ _) = do
|
|
leave ("Ok " ++ n ++ ", I'm quitting!")
|
|
action "implode" (Message n _ _) = do
|
|
leave ("whoooooooshhhhh ...")
|
|
action "explode" (Message n _ _) = do
|
|
leave ("KaaboooOOOOOooooommm ...")
|
|
action "help" (Message n _ _) = help n
|
|
action "cleanup" (Message n _ _) = cleanup n
|
|
action s (Message n _ _) = do
|
|
case (length s) of
|
|
0 -> privmsg "What?!"
|
|
_ -> privmsg ("Fuck you " ++ n ++ "! " ++
|
|
sanit (capitalize s) ++ " yourself!")
|
|
where
|
|
capitalize (x:xs) = toUpper x : xs
|
|
sanit xs = case [(last xs)] `isInfixOf` ".:!?" of
|
|
True -> take (length xs - 1) xs
|
|
False -> xs
|
|
|
|
rest :: String -> String -> String
|
|
rest k s = drop (length k + 1) s
|
|
|
|
privmsg :: String -> MyStateM ()
|
|
privmsg s = write "PRIVMSG" (chan ++ " :" ++ s)
|
|
|
|
msg :: String -> Nick -> MyStateM ()
|
|
msg s n = write "PRIVMSG" (n ++ " :" ++ s)
|
|
|
|
leave :: String -> MyStateM ()
|
|
leave s = do
|
|
privmsg s
|
|
write "PART" (chan ++ " :")
|
|
|
|
invited :: MyStateM ()
|
|
invited = joinChan
|
|
|
|
parse :: String -> Maybe Message
|
|
parse s = do
|
|
-- :Jeena!~Jeena@host-3AB762DD.defunced.de PRIVMSG #jeena :test
|
|
let pat = ":([a-zA-Z0-9].+)!.+ ([A-Z].+) " ++ chan ++ " :(.*)"
|
|
let q = s =~ pat :: [[String]]
|
|
-- :Jeena!~Jeena@host-3AB762DD.defunced.de INVITE cnb :#jeena
|
|
let pat2 = ":([a-zA-Z0-9].+)!.+ ([A-Z].+) " ++ nick ++ " :" ++ chan
|
|
let q2 = s =~ pat2 :: [[String]]
|
|
case q of
|
|
[] -> do case q2 of
|
|
[] -> Nothing
|
|
r2 -> do let a2 = tail $ head r2
|
|
case (head $ tail a2) of
|
|
"INVITE" -> Just (Message (head a2) Invite (last a2))
|
|
_ -> Nothing
|
|
r -> do let a = tail $ head r
|
|
case (head $ tail a) of
|
|
"KICK" -> Just (Message (head a) Kick (last a))
|
|
"PRIVMSG" -> Just (Message (head a) Privmsg (last a))
|
|
_ -> Nothing
|
|
|
|
parseKeyVal :: String -> (Key, Value)
|
|
parseKeyVal s = do
|
|
let a = wordsBy (=='~') s
|
|
(head a, unwords $ tail a)
|
|
|
|
wordsBy :: (a -> Bool) -> [a] -> [[a]]
|
|
wordsBy sep str = s_skip str
|
|
where s_skip [] = []
|
|
s_skip (c:cs) = if sep c then s_skip cs else s_word cs [c]
|
|
s_word [] w = [reverse w]
|
|
s_word (c:cs) w = if sep c then reverse w : s_skip cs
|
|
else s_word cs (c:w)
|
|
|
|
trim :: String -> String
|
|
trim = f . f
|
|
where f = reverse . dropWhile isSpace
|
|
|
|
help :: Nick -> MyStateM ()
|
|
help n = do
|
|
privmsg "Heaven helps those who help themselves."
|
|
msg ("usage:") n
|
|
msg (" " ++ nick ++ ": help -> this help") n
|
|
msg (" " ++ nick ++ ": add regex~value -> adds a value for a regex") n
|
|
msg (" " ++ nick ++ ": delete regex -> deletes the regex-value pair") n
|
|
msg (" " ++ nick ++ ": list -> lists all available regex-value pairs") n
|
|
msg (" " ++ nick ++ ": cleanup -> restores the list to the default") n
|
|
msg (" " ++ nick ++ ": leave -> bot leaves the chanel") n
|
|
msg (" " ++ nick ++ ": explode -> bot leaves the chanel") n
|
|
msg (" " ++ nick ++ ": implode -> bot leaves the chanel") n
|
|
msg (" /invite " ++ nick ++ " " ++ chan ++ " -> invites the bot back to the chanel") n
|
|
|
|
cleanup :: Nick -> MyStateM ()
|
|
cleanup n = do
|
|
putStore startStore
|
|
privmsg "Ok, I've cleaned up the bloody list."
|
|
|
|
startStore :: Store
|
|
startStore = [
|
|
("^jump$", "The quick brown clynx jumps over the lazy oak."),
|
|
("^ok$", "ok"),
|
|
("(J|j)eena(,|:)? arbeitest du?", "Jeena, sag doch mal."),
|
|
-- (nick, "Keine ungefragten queries!"),
|
|
("(php|PHP)", "'PHP' <- Ha ha!</nelson>"),
|
|
("(E|e)rlang", "Oh yeah!"),
|
|
("(H|h)askell", "Ich bin in Haskell geschrieben."),
|
|
("danke", "np"),
|
|
-- ("^hehe$", "was gibt es da zu lachen?"),
|
|
("^np$", "schmück dich nicht mit fremden Federn.")
|
|
]
|
|
|
|
-- ü |