Permalink
Browse files

Gittin' it up

  • Loading branch information...
Jonas Westerlund
Jonas Westerlund committed Oct 3, 2010
0 parents commit 3a0a32e0a8907f087ce067c844d5be98d4af3c06
Showing with 640 additions and 0 deletions.
  1. +68 −0 Eval.hs
  2. +88 −0 IRC.hs
  3. +77 −0 L.hs
  4. +30 −0 LICENSE
  5. +41 −0 Main.hs
  6. +63 −0 Parser.hs
  7. +139 −0 Seen.hs
  8. +2 −0 Setup.hs
  9. +16 −0 TODO
  10. +40 −0 Types.hs
  11. +18 −0 Utils.hs
  12. +58 −0 norby.cabal
68 Eval.hs
@@ -0,0 +1,68 @@
+module Eval where
+
+import Control.Monad.Reader
+import Data.Char
+import Data.List
+
+import Mueval.ArgsParse
+import Mueval.Interpreter
+import Mueval.Parallel
+
+import qualified Language.Haskell.Interpreter as I
+
+import System.IO.Error
+import System.Process
+import Types
+import Utils
+
+hsFile = "L"
+
+-- Call out to the mueval binary
+evalHsExt :: Message -> IO String
+evalHsExt (Message _ _ params) = do
+ (_, out, _) <- liftIO $ readProcessWithExitCode "mueval" args ""
+ return $ " " ++ (unwords $ words out)
+ where args = ["-XExtendedDefaultRules",
+ "-XUnicodeSyntax",
+ "--noimports",
+ "-l", hsFile ++ ".hs",
+ "--expression=" ++ (drop 2 . last) params,
+ "-t30",
+ "+RTS", "-N2", "-RTS"]
+
+-- Evaluate a Haskell expression
+evalHs :: String -> IO String
+evalHs expr = do
+ r <- liftIO . I.runInterpreter . interpreter $ muOptions { expression = expr }
+ case r of
+ Left (I.WontCompile errs) -> return $ niceErrors errs
+ Left err -> error $ intercalate " " . lines $ show err
+ -- Expr, type, and result
+ Right (_, _, r) -> return $ " " ++ r
+
+ where muOptions = (getOptions []) { expression = expr,
+ loadFile = hsFile,
+ timeLimit = 5 }
+
+-- Get inferred type of an expression
+typeOf :: Message -> IO String
+typeOf (Message _ _ params) = do
+ -- ".type expr" -> "expr"
+ let expr = drop 6 $ last params
+ t <- liftIO . I.runInterpreter $ I.loadModules [hsFile]
+ >> I.setTopLevelModules [hsFile]
+ >> I.setImports ["Prelude"]
+ >> I.typeOf expr
+ case t of
+ Left (I.WontCompile errs) -> return $ niceErrors errs
+ Left err -> return $ show err
+ Right val -> return val
+
+niceErrors = excerpt' . intercalate " " . concatMap lines . fmap I.errMsg
+
+-- Pointfree refactoring
+pointFree :: Message -> IO String
+pointFree (Message _ _ params) = do
+ let expr = trim . dropWhile (not . isSpace) $ last params
+ (_, out, _) <- liftIO $ readProcessWithExitCode "pointfree" [expr] ""
+ return . intercalate " " $ lines out
88 IRC.hs
@@ -0,0 +1,88 @@
+module IRC (
+ module Parser,
+ Net,
+ connect,
+ listen,
+ privmsg,
+ socket,
+ write
+) where
+
+import Control.OldException (bracket_)
+import Control.Monad
+import Control.Monad.Reader hiding (join)
+import Data.Either
+import Data.List
+import qualified Eval as E
+import Network
+import Parser
+import qualified Seen as S
+import System.Exit
+import System.IO
+import Text.ParserCombinators.Parsec hiding (letter)
+import Types
+
+import qualified Utils as U
+
+-- A wrapper over IO, holding the bot's immutable state
+type Net = ReaderT Bot IO
+data Bot = Bot Handle
+
+socket :: Bot -> Handle
+socket (Bot h) = h
+
+-- Connect to the server and return the initial bot state
+connect :: String -> Int -> IO Bot
+connect s p = notify $ do
+ h <- connectTo s $ PortNumber (fromIntegral p)
+ hSetBuffering h NoBuffering
+ return $ Bot h
+ where notify a = bracket_
+ (print ("Connecting to " ++ s ++ "...") >> hFlush stdout)
+ (print "It is so.") a
+
+-- write $ Message (Maybe ett prefix) Command [parametrar]
+-- write $ Message Nothing "LOL" ["nyeyhehe"]
+write :: Message -> Net ()
+write msg = do
+ h <- asks socket
+ liftIO $ hPrint h msg
+ liftIO $ S.store msg
+ liftIO . putStrLn $ "sent: " ++ (show msg)
+
+-- Prettier ones for later use :)
+-- write msg = liftIO . flip hPrint msg =<< asks socket
+-- write = (asks socket >>=) . (liftIO .) . flip hPrint
+
+-- Process lines from the server
+listen :: Handle -> Net ()
+listen h = forever $ do
+ s <- init `fmap` liftIO (hGetLine h)
+ let Just msg = parseMessage s -- Uh oh!
+ liftIO . putStrLn $ "got: " ++ s
+ liftIO $ S.store msg -- Store every message in MongoDB
+ ping msg
+ where ping (Message _ "PING" p) = write $ Message Nothing "PONG" p
+ ping message = eval message
+
+-- Perform a command
+eval :: Message -> Net ()
+eval msg@(Message _ _ params@(p:_))
+ | ".join " `isPrefixOf` lastPar = write $ Message Nothing "JOIN"
+ (take 1 . drop 1 $ words lastPar)
+ | ".part " `isPrefixOf` lastPar = write $ Message Nothing "PART"
+ (take 1 . drop 1 $ words lastPar)
+ | "> " `isPrefixOf` lastPar = eval' E.evalHsExt msg
+ | ".type " `isPrefixOf` lastPar = eval' E.typeOf msg
+ | ".gtfo " `isPrefixOf` lastPar = write $ Message Nothing "QUIT" ["lol haahaha!"]
+ | ".seen " `isPrefixOf` lastPar = eval' S.seen msg
+ | ".pf " `isPrefixOf` lastPar = eval' E.pointFree msg
+ | otherwise = return ()
+ where eval' f msg = liftIO (f msg) >>= privmsg chan
+ lastPar = last params
+ chan = p
+
+eval (Message _ _ _) = return ()
+
+privmsg :: String -> String -> Net ()
+privmsg c m = write $ Message Nothing "PRIVMSG" [c, U.excerpt' m]
77 L.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+module L where
+
+import Control.Arrow
+import Control.Monad
+import Control.Monad.State
+import Control.Monad.Trans
+import Data.Char
+import Data.Function
+import Data.Functor
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.Ratio
+import Numeric
+import System
+import System.IO
+import System.Process
+import System.Random
+
+interleave [] _ = []
+interleave (x:xs) ys = x : interleave ys xs
+
+padl n p s = pad n p s ++ s
+padr = (ap (++) .) . pad
+pad = (flip (drop . length) .) . replicate
+
+rgbToHex (r, g, b)
+ | all ok rgb = '#' : concatMap (padl 2 '0' . flip showHex "") rgb
+ | otherwise = error "All numbers must be >= 0 and <= 255"
+ where ok = liftM2 (&&) (<= 255) (>= 0)
+ rgb = [r, g, b]
+
+-- temp01's magical function
+oOo [] = [];
+oOo s = concat [init s, [toUpper (last s)], tail (reverse s)]
+
+type Peen = String
+ben :: Int -> Peen
+ben = ('8' :) . (++ "D") . flip replicate '='
+
+gf n | n < 0 = "NEGATIVE U"
+ | n == 0 = "N'T U"
+ | n <= 9000 = (unwords . replicate n) "NO" ++ " U"
+ | otherwise = "It's over 9000!"
+
+ajpiano = "PANDEMONIUM!!!"
+
+akahn s | last s == '?' = "did you mean " ++ s
+ | otherwise = "that's not " ++ s
+
+coldhead s | null s = ">: |"
+ | otherwise = "these are truly the last " ++ s
+
+dabear = ("your mom " ++)
+
+dytrivedi s | null s = "my wife is happy"
+ | otherwise = mappend "my wife is annoyed i spend so much time " s
+
+matjas = interleave "matjas" . enumFrom
+
+miketaylr s | null ts = "here, let me open that... wait a minute, there's nothing there, you bitch!"
+ | otherwise = unwords ["here, let me open that", s, "for you!"]
+ where ts = trim s
+
+nlogax = (++ "n't")
+paul_irish = "ryan_irelan"
+sean = "koole"
+seutje = ("I would of " ++)
+temp01 = Just "awesome"
+vladikoff = ("flod " ++) . (++ "!!")
+
+mlu = "much like urself"
+muu = "much unlike urself"
+
+trim = trim' . trim'
+ where trim' = reverse . dropWhile isSpace
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c)2010, Jonas Westerlund
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Jonas Westerlund nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
41 Main.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Control.OldException
+import Control.Monad.Reader hiding (join)
+import Data.List
+import Prelude hiding (catch)
+import System.IO
+
+import IRC hiding (message)
+import Types
+
+--server = "wineasy.se.quakenet.org"
+server = "chat.us.freenode.net"
+port = 6667
+nickn = "ultror"
+name = "ultror"
+
+channels = intercalate "," ["#clojure",
+ "#jquery",
+ "#jquery-ot",
+ "#runlevel6",
+ "#ultror"]
+
+-- Set up actions to run on start and end, and run the main loop
+main :: IO ()
+main = bracket (connect server port) disconnect loop
+ where disconnect = hClose . socket
+ loop st = catch (runReaderT run st) (const $ return ())
+
+-- Join some channels, and start processing commands
+run :: Net ()
+run = do
+ write $ Message Nothing "USER" [nickn, "0", "*", name]
+ write $ Message Nothing "NICK" [nickn]
+ write $ Message Nothing "JOIN" [channels]
+ asks socket >>= listen
+
+-- Authorized bot wranglers
+admins = nicks ["ajpiano akahn BBonifield coldhead gf3 matjas miketaylr",
+ "nimbupani nlogax paul_irish seutje temp01"]
+ where nicks = words . unlines
@@ -0,0 +1,63 @@
+module Parser where
+
+import Data.Maybe
+import Text.ParserCombinators.Parsec hiding (letter, space)
+import Types
+
+parseMessage :: String -> Maybe Message
+parseMessage s = either (const Nothing) Just (parse message "" s)
+
+-- <message> ::= [':' <prefix> <SPACE> ] <command> <params> <crlf>
+message = do
+ p <- optionMaybe (char ':' >> prefix >>= (space >>) . return)
+ c <- command
+ ps <- many (space >> params)
+-- _ <- crlf
+ return $ Message p c ps
+-- <prefix> ::= <servername> | <nick> [ '!' <user> ] [ '@' <host> ]
+prefix = try nickPrefix <|> serverPrefix
+
+-- <command> ::= <letter> { <letter> } | <number> <number> <number>
+command = many1 letter <|> count 3 number -- Either one or more letters, or three numbers
+-- <SPACE> ::= ' ' { ' ' }
+space = many1 $ char '\SP'
+-- <params> ::= <SPACE> [ ':' <trailing> | <middle> <params> ]
+params = optionMaybe ((char ':' >> trailing) <|> middle) >>= return . fromMaybe ""
+-- <middle> ::= <Any *non-empty* sequence of octets not including SPACE or NUL or CR or LF, the first of which may not be ':'>
+middle = many1 nonWhite
+
+-- <trailing> ::= <Any, possibly *empty*, sequence of octets not including NUL or CR or LF>
+trailing = many $ noneOf "\NUL\CR\LF"
+-- <crlf> ::= CR LF
+crlf = string "\CR\LF"
+
+-- <host> ::= see RFC 952 [DNS:4] for details on allowed hostnames
+host = many1 $ noneOf " @!"
+
+-- <nick> ::= <letter> { <letter> | <number> | <special> }
+-- This is more liberal than the RFC, to make it work IRL
+nick = many1 (letter <|> number <|> special)
+
+nickPrefix = do
+ n <- nick
+ _ <- notFollowedBy $ char '.'
+ u <- optionMaybe (char '!' >> user)
+ h <- optionMaybe (char '@' >> host)
+ return $ NickName n u h
+
+
+serverName = host
+serverPrefix = serverName >>= return . Server
+
+-- <user> ::= <nonwhite> { <nonwhite> }
+user = many1 $ noneOf "\SP\NUL\CR\LF\64"
+
+-- <letter> ::= 'a' ... 'z' | 'A' ... 'Z'
+letter = oneOf $ ['a'..'z'] ++ ['A'..'Z']
+-- <number> ::= '0' ... '9'
+number = oneOf ['0'..'9']
+-- <special> ::= '-' | '[' | ']' | '\' | '`' | '^' | '{' | '}'
+special = oneOf "-[]\\`^{}_|" -- Added "_|", because IRL /= RFC
+
+-- <nonwhite> ::= <any 8bit code except SPACE (0x20), NUL (0x0), CR (0xd), and LF (0xa)>
+nonWhite = noneOf "\SP\NUL\CR\LF"
Oops, something went wrong.

0 comments on commit 3a0a32e

Please sign in to comment.