the one where devbot learns some people are cool

src/devbot.hs

@@ -36,8 +36,8 @@ import qualified GitHub.Endpoints.Issues.Milestones as G
 
 
 ournick =   "devbot"
-server  =   "irc.freenode.org"
-port    =   7070
+server  =   "irc.freenode.net"
+port    =   6697
 chans   =   [   "#devbot-dev"
             ,   "#utox"
             ,   "#epic_cms"
@@ -50,29 +50,31 @@ regex_GH_num    = "(#[0-9]{1,5})" :: String
 regex_GH_repo   = "([a-zA-Z0-9.-]+)"   ++ regex_GH_num
 regex_GH_owner  = "([a-zA-Z0-9.-]+)/"  ++ regex_GH_repo
 regex_gl        = "((^|\\s)![0-9]{1,5})" :: String
-regex_gli       = "((^|\\s)i[0-9]{1,5})" :: String
 
 data Bot = Bot
     {   socket      :: Connection
     ,   channels    :: [Channel]
+    ,   people      :: [User]
     ,   start_time  :: UTCTime
     }
 
+data User = User
+    {   nick    :: String
+    ,   user    :: String
+    ,   host    :: String
+    ,   monolog :: Int
+    ,   karma   :: Int
+    } deriving (Eq, Show)
+
 data Channel = Channel
     {   chname          :: String
-    ,   users           :: [User]
+    ,   users           :: [String]
     ,   default_rown    :: String
     ,   default_repo    :: String
     } deriving (Eq, Show)
 
 type Net  = StateT Bot IO
 
-data User = User
-    {   nick :: String
-    ,   user :: String
-    ,   host :: String
-    } deriving (Eq, Show)
-
 ------------------------------------------------
 --  IRC connection and logic
 ------------------------------------------------
@@ -93,7 +95,7 @@ conn = do
                                             ,   connectionUseSocks  = Nothing
                                             }
     c <- getCurrentTime
-    return (Bot irc_conn [] c)
+    return (Bot irc_conn [] [] c)
     where
         notify a = bracket_ (printf "connecting to %s..." server >> hFlush stdout) (putStrLn "connected!") a
 
@@ -108,19 +110,19 @@ listen :: Net ()
 listen = forever $ do
     h <- gets socket
     string <- readLine h
-    -- string <- raw
     -- TODO sanitize utf-8 for the broken version of haskell on debian
     if "PING :" `isPrefixOf` string
         then io $ connectionPut h (CHAR8.pack $ "PONG :" ++ string ++ "\r\n")
         else do io $ putStrLn string
+                overhead (source string) (action string) (target string) (message string)
                 eval (source string) (action string) (target string) (message string)
   where
     forever a = do a; forever a
 
     source  = takeWhile (/= ' ') . drop 1
     action  = takeWhile (/= ' ') . drop 1 . dropWhile (/= ' ')
-    target  = takeWhile (/= ' ') . drop 1 . dropWhile (/= ' ') . drop 1 . dropWhile (/= ' ')
-    message = drop 1 . dropWhile (/= ':') . drop 1
+    target  = init . takeWhile (/= ':') . drop 1 . dropWhile (/= ' ') . drop 1 . dropWhile (/= ' ')
+    message = drop 1 . dropWhile (/= ':') . drop 1 . init
 
 readLine :: Connection -> Net (String)
 readLine con = do
@@ -133,16 +135,33 @@ write string text = do
     h <- gets socket
     io $ connectionPut h $ CHAR8.pack (string ++ " " ++ text ++ "\r\n")
 
+------------------------------------------------
+--  Overhead / Bot Maintenance
+------------------------------------------------
+overhead :: String -> String -> String -> String -> Net ()
+overhead src _ _ _ = do
+    users <- gets people
+    let uniq = nub (users ++ [mkUser src])
+    modify (\b -> b { people = uniq })
+
 ------------------------------------------------
 --  Main processor
 ------------------------------------------------
 eval :: String -> String -> String -> String -> Net ()
 eval _ "332" _ _ = io $ putStrLn "DEBUG__ GOT CHAN TOPIC"
 eval _ "333" _ _ = io $ putStrLn "DEBUG__ GOT CHAN TOPIC SETBY"
-eval _ "353" _ _ = io $ putStrLn "DEBUG__ GOT USER LIST"
 eval _ "366" _ _ = io $ putStrLn "DEBUG__ EOF USER LIST"
 eval _ "473" _ _ = io $ putStrLn "DEBUG__ UNABLE TO JOIN CHANNEL (not invited)"
-eval source action target "is now your hidden host (set by services.)" = do
+
+eval _ "353" trg msg = do
+    ch_list <- gets channels
+    let target_chan = dropWhile (/= '#') trg
+    let old_ch = head $ filter (\x -> target_chan == chname x) ch_list
+    let new_ch = foldl chanAddUser old_ch (words msg)
+    let chans = nubBy (\x y -> chname x == chname y) $ new_ch : ch_list
+    modify (\bot -> bot { channels = chans })
+    -- dumpChans chans
+eval _ "396" _ _ = do -- Host Mask Set, it's safe to join channels now
     mapM joinChan chans
     return()
 eval _ "INVITE" _ chan = do
@@ -161,18 +180,45 @@ eval source action target msg
     | "allah is doing" `isInfixOf` msg = kickBan target source
     -- Actual work
     -- check commands before checking regex
-    | "!" `isPrefixOf` msg = botCommand source action target msg
+    | "!" `isPrefixOf` msg = do
+        if msg =~ regex_gl
+            then do
+                mapM_ (gitLabMagic target) ((getAllTextMatches $ msg =~ regex_gl) :: [String])
+                return ()
+            else botCommand source action target msg
     -- regex searches
     | msg =~ ("[Dd]evbot[;:,]?" :: String) = evalMention source action target msg
+    | msg =~ mtch_good = do
+        ps <- gets people
+        let n = (takeWhile (/= '+') $ msg =~ mtch_good)
+        let user = findUser n ps
+        if isJust user
+            then do
+                let u = (userModKarma (fromJust user) 1 )
+                let pss = u : ps
+                modify (\bot -> bot { people = nub pss })
+            else return ()
+    | msg =~ mtch_bad = do
+        ps <- gets people
+        let n = (takeWhile (/= '-') $ msg =~ mtch_bad)
+        let user = findUser n ps
+        if isJust user
+            then do
+                let u = (userModKarma (fromJust user) (-1))
+                let pss = u : ps
+                modify (\bot -> bot { people = nub pss })
+            else return ()
     | msg =~ regex_GH_num = issueFinder target msg
-    | msg =~ regex_gl  = do
+    | msg =~ regex_gl = do
         mapM_ (gitLabMagic target) ((getAllTextMatches $ msg =~ regex_gl) :: [String])
         return ()
-    | msg =~ regex_gli = privMsg target $ "https://gitlab.com/uTox/uTox/issues/"         ++ drop 1 (msg =~ regex_gli)
     -- be funny!
     | "that's wrong!"  `isInfixOf`  msg = privMsg target "OH NO! someone is wrong on the internet! https://xkcd.com/386/"
     | "shit's fucked" `isInfixOf` msg = privMsg target "https://www.youtube.com/watch?v=HAEZaUYoJRc"
     | otherwise = return ()
+    where
+        mtch_good = ("([a-zA-Z0-9.-]+)\\+\\+" :: String)
+        mtch_bad = ("([a-zA-Z0-9.-]+)--" :: String)
 
 gitLabMagic :: String -> String -> Net ()
 gitLabMagic x y = privMsg x $ "https://gitlab.com/uTox/uTox/merge_requests/" ++ drop 1 (dropWhile (/= '!') y)
@@ -186,24 +232,31 @@ evalMention _ _ t msg
     | msg =~ ("(you're|your|is) awesome" :: String) = privMsg t "Awww... I love you too!"
     | msg =~ ("what(')?s (next|left)\\?" :: String) = eval "" "" t "!m"
     | msg =~ ("^[Dd]evbot[;:,]? " :: String) = privMsg t "You said my name!! :D"
+    | msg =~ ("oh, I mean" :: String) = privMsg t "A common typo, they keys are right next to each other, really..."
     | otherwise = return ()
 
 botCommand :: String -> String -> String -> String -> Net ()
 botCommand _ _ target "!moose"        = privMsg target "https://www.youtube.com/watch?v=7fE0YhEFvx4"
 botCommand _ _ target "!commitsudoku" = privMsg target "http://www.sudokuweb.org/"
 botCommand _ _ target "!uptime"       = uptime >>= privMsg target
 botCommand _ _ target "!rip"          = sayRip target
-botCommand _ _ target "!m"            = io (nextMilestone True "TokTok" "c-toxcore") >>= privMsg target
+botCommand _ _ target "!m"            = io (nextMilestone True (drop 1 target) ("c-toxcore")) >>= privMsg target
 botCommand _ _ target "!echo"         = privMsg target "Echo what exactly?"
 botCommand source action target msg
     -- all the cool commands we do stuff with
+    | "!k " `isPrefixOf` msg = do
+        peoples <- gets people
+        let users = filter (\x -> drop 3 msg == nick x) peoples
+        if null users
+            then privMsg target "666: Karma Not Found"
+            else privMsg target $ drop 3 msg ++ " has " ++ show (userKarma $ head users)
     | "!echo " `isPrefixOf` msg = do
         privMsg target $ drop 6 msg
     | "!die" == msg = do
         privMsg target "Sure, I'll just DIE then!"
         write "QUIT" ":My death was ordered" >> io (exitWith ExitSuccess)
     | "!milestone" `isPrefixOf` msg = do
-        text <- io $ nextMilestone False "TokTok" "c-toxcore"
+        text <- io $ nextMilestone False (drop 1 target) ("c-toxcore")
         privMsg target $ text
     | "!status " `isPrefixOf` msg = do
         let s = chkStatus $ takeWhile (/= ' ') . drop 8 $ msg
@@ -213,6 +266,7 @@ botCommand source action target msg
     | "!set "    `isPrefixOf` msg = setState source target (drop 5 msg)
     | "!ghost "  `isPrefixOf` msg = privMsg ((takeWhile (/= ' ') . drop 7) msg) ((drop 1 . dropWhile (/= ' ') . drop 8) msg)
     | "!join "   `isPrefixOf` msg = joinChan ((takeWhile (/= ' ') . drop 6) msg)
+    | "!invite " `isPrefixOf` msg = chanInviteUser (takeWhile (/= ' ') msg ) (takeWhile (/= ' ') . dropWhile (/= ' ') $ msg)
     | "!build "  `isPrefixOf` msg = do
         res <- io $ ciTriggerGitlab $ (takeWhile (/= ' ') . drop 7) msg
         if res
@@ -241,7 +295,7 @@ sayRip t = do
     privMsg t "Poor one out for the devs Tox has eaten"
     privMsg t "irungentoo 2013-2016"
     privMsg t "iphy 2015-2017"
-    privMsg t "mannol 2014-2016"
+    privMsg t "mannol 2013-2016"
     privMsg t "jfreegman 2014-2015"
     privMsg t "May Tox rest their soul..."
 
@@ -254,6 +308,26 @@ chkStatus "qtox"    = Just "qTox's current status :: https://utox.io/qtox.jpg ::
 chkStatus "utox"    = Just "uTox's current status :: https://utox.io/utox.png"
 chkStatus _         = Nothing
 
+findUser :: String -> [User] -> Maybe User
+findUser name list = do
+    let matches = filter (\x -> nick x == name) list
+    if null matches
+        then Nothing
+        else Just $ head matches
+
+mkUser :: String -> User
+mkUser str = (User (n str) (u str) (h str) 0 0)
+    where
+        n = takeWhile (/= '!')
+        u = drop 1 . takeWhile (/= '@') . dropWhile (/= '!')
+        h = drop 1 . dropWhile (/= '@')
+
+userModKarma :: User -> Int -> User
+userModKarma user change = user { karma = (karma user) + change }
+
+userKarma :: User -> Int
+userKarma u = karma u
+
 kickBan :: String -> String -> Net ()
 kickBan channel shitball = do
     setBan channel shitball
@@ -269,47 +343,55 @@ chanMode :: String -> String -> String -> Net ()
 chanMode mode target user = do
     write "MODE" $ target ++ " " ++ mode ++ " " ++ user
 
+chanAddUser :: Channel -> String -> Channel
+chanAddUser old user = old { users = user : users old }
+
 dumpChans :: [Channel] -> Net ()
-dumpChans channs = mapM_ (\x -> io $ putStrLn ((chname x) ++ " " ++ (default_repo x))) channs
+dumpChans channs = mapM_ (\x -> io $ putStrLn ("DMPCHN: " ++ (chname x) ++ " -- " ++ (default_repo x) ++ unwords (users x) )) channs
 
 chanSetRepo :: String -> String -> Net ()
 chanSetRepo search repo = do
     real <- gets channels
     let (ch, other) = botPopChan search real
-    if null ch
-        then return ()
-        else do
-            let ch' = head ch -- We're just guessing here :<
-            let ch2 = ch' { default_repo = repo }
-            let new = nubBy (\x y -> chname x == chname y) $ ch2 : other
-            modify (\bot -> bot { channels = new })
+    let ch2 = ch { default_repo = repo }
+    let new = nubBy (\x y -> chname x == chname y) $ ch2 : other
+    modify (\bot -> bot { channels = new })
 
 chanSetOwn :: String -> String -> Net ()
 chanSetOwn search owner = do
     real <- gets channels
     let (ch, other) = botPopChan search real
-    if null ch
-        then return ()
-        else do
-            let ch' = head ch -- We're just guessing here :<
-            let ch2 = ch' { default_rown = owner }
-            let new = nubBy (\x y -> chname x == chname y) $ ch2 : other
-            modify (\bot -> bot { channels = new })
+    let ch2 = ch { default_rown = owner }
+    let new = nubBy (\x y -> chname x == chname y) $ ch2 : other
+    modify (\bot -> bot { channels = new })
+
+chanInviteUser :: String -> String -> Net ()
+chanInviteUser chan user = invtMsg $ "" ++ user ++ " " ++ chan
+
+invtMsg :: String -> Net ()
+invtMsg msg = write "INVITE" $ msg
 
 privMsg :: String -> String -> Net ()
 privMsg to text = write "PRIVMSG" $ to ++ " :" ++ text
 
 chNick :: String -> Net ()
 chNick nick = write "NICK" nick
 
-botPopChan :: String -> [Channel] -> ([Channel], [Channel])
-botPopChan search cs = partition (\x -> search == chname x) cs
+mkChan :: String -> Channel
+mkChan c = Channel c [] (drop 1 c) []
+
+botPopChan :: String -> [Channel] -> (Channel, [Channel])
+botPopChan search cs = do
+    let (a, b) = partition (\x -> search == chname x) cs
+    if null a
+        then (mkChan search, b)
+        else (head a, b)
 
 joinChan :: String -> Net ()
 joinChan c = do
     write "JOIN" c
     old <- gets channels
-    let chan = (Channel c [] [] [])
+    let chan = mkChan c
     let new = nubBy (\x y -> chname x == chname y) $ chan : old
     -- dumpChans new
     modify (\bot -> bot { channels =  new })
@@ -327,9 +409,7 @@ issueFinder :: String -> String -> Net ()
 issueFinder trg msg = do
     allchan <- gets channels
     let (ch, _) = botPopChan trg allchan
-    let (owner, repo, inum) = parseIssueRequest (head ch) trg msg
-    gl <- io $ glIssueFind inum
-    privMsg trg gl
+    let (owner, repo, inum) = parseIssueRequest ch trg msg
     url <- io $ checkIssue owner repo $ read inum
     if isJust url
         then privMsg trg $ fromJust url
@@ -424,7 +504,6 @@ realIssue repo_name owner issu_numb issue = do
         then return (Just (str ++ "|| https://reviewable.io/reviews/" ++ owner ++ "/" ++ repo_name ++ "/" ++ show issu_numb))
         else return (Just str)
 
-
 ------------------------------------------------
 --  GitLab helpers
 ------------------------------------------------