Browse files

Use getOpt. Nicer local prompt. Terse mode.

darcs-hash:20070822192149-ec8c9-daedf68823ef1d3566c2f318f6ba7f7371a7bf86.gz
  • Loading branch information...
1 parent e465d97 commit fc774c96532913ad5506716c57ddd25444cfb3e7 @Eelis committed Aug 22, 2007
Showing with 129 additions and 39 deletions.
  1. +2 −1 INSTALL.xhtml
  2. +57 −0 res/terse.hpp
  3. +50 −36 src/Bot.hs
  4. +20 −2 src/Util.hs
View
3 INSTALL.xhtml
@@ -54,6 +54,7 @@
<li>Edit `config' to your liking.</li>
<li><kbd>mkdir rt</kbd> # This will be our chroot root.</li>
<li>scripts/compile-prelude # To produce rt/prelude.h.gch and a few rt/foo.o's.</li>
+ <li><kbd>cp res/terse.hpp rt/</kbd></li>
<li><kbd>rtcp () { cp -L -r -v --parents $@ rt ; }</kbd></li>
<li><kbd>libs () { echo `ldd $@ | grep -o -P "(?&lt;=\\s)/\\S*" | sort | uniq` ; }</kbd></li>
<li><kbd>EXECS="`which g++ as ld strace` /usr/lib/gcc/i586-suse-linux/4.1.2/cc1plus"</kbd> # Correct the last one for your system.</li>
@@ -64,7 +65,7 @@
<li><kbd>sudo chroot rt /a.out &amp;&amp; echo</kbd> # This may complain a bit more about missing libraries, which again should be copied into rt using rtcp. Eventually, it should print "9".</li>
<li><kbd>sudo scripts/trace-execs</kbd></li>
<li><kbd>find rt -perm -o+w</kbd> # This should list exactly four files: rt/t.o, rt/t.s, rt/t.cpp, and rt/t.</li>
- <li><kbd>find rt -user nobody</kbd> # This should find no files at all.</li>
+ <li><kbd>find rt -user nobody</kbd> # This should find nothing.</li>
<li><kbd>sudo ./Bot "geordi-clone &lt;&lt; 'x'"</kbd> # If this does not print 'x', something is messed up. (Replace "geordi-clone" with the configured nick, of course.)</li>
<li>If you want, you can now <kbd>rm -f rt/usr/bin/strace rt/usr/bin/g++</kbd></li>
<li>To get an idea of what rt could look like, look at the tree and file listing below.</li>
View
57 res/terse.hpp
@@ -0,0 +1,57 @@
+
+// Keywords:
+#define au auto
+#define brk break
+#define cat catch
+#define cexpr constexpr
+#define cls class
+#define co const
+#define dlt delete
+#define def default
+#define dtp decltype
+#define dub double
+#define dcast dynamic_cast
+#define expl explicit
+#define ext extern
+#define ff false
+#define flt float
+#define inl inline
+#define tpd typedef
+#define tpn typename
+#define mut mutable
+#define ns namespace
+#define op operator
+#define pub public
+#define pvt private
+#define prt protected
+#define reg register
+#define ret return
+#define rcast reinterpret_cast
+#define st struct
+#define stc static
+#define scast static_cast
+#define sass static_assert
+#define tmpl template
+#define tid typeid
+#define tt true
+#define use using
+#define vol volatile
+#define vrt virtual
+#define wh while
+// No need for #define uns unsigned, because we have uint/ulong/uchar typedefs.
+
+// Stdlib:
+#define ass assert
+#define iter iterator
+typedef ::std::string str;
+ // The following are to be replaced with template aliases at some point.
+#define vec ::std::vector
+#define umap ::std::unordered_map
+#define uset ::std::unordered_set
+#define numlim ::std::numeric_limits
+
+// Boost:
+#define lcast ::boost::lexical_cast
+#define foreach BOOST_FOREACH
+using boost::next;
+using boost::prior;
View
86 src/Bot.hs
@@ -1,23 +1,24 @@
import Network (PortID(..), connectTo)
-import System.IO (hSetBuffering, BufferMode(..), hGetLine)
+import System.IO (hSetBuffering, BufferMode(..), hGetLine, hFlush, stdout)
import System.Environment (getArgs)
import System.Directory (setCurrentDirectory, getDirectoryContents)
import System.Posix.Process (getProcessID)
import System.Posix.Env (setEnv)
import System.Posix.User
import System.Posix.Resource
-import Control.Monad.Reader
+import Control.Monad.Error
import Control.Monad
import Text.ParserCombinators.Parsec
-import Prelude hiding (catch, (.), readFile, putStrLn, print)
+import Prelude hiding (catch, (.), readFile, putStrLn, putStr, print)
import Data.Char
import Data.List ((\\))
import Data.Maybe
import EvalCpp (evalCpp)
import qualified EvalCpp
import Util
import System.IO.UTF8 hiding (hGetLine, getLine)
+import System.Console.GetOpt
data BotConfig = BotConfig
{ server :: String, port :: Integer, max_msg_length :: Int
@@ -54,24 +55,40 @@ jail cfg = do
setGroupID gid
setUserID uid
-cmd_parser :: String -> CharParser st (Bool, String)
-cmd_parser [] = error "cannot have empty bot name"
-cmd_parser (botnick_h:botnick_t) = do
- spaces
- oneOf [toLower botnick_h, toUpper botnick_h]
- -- There is currently no proper case-insensitive char/string comparison function in Data.Char (see GHC ticket #1506).
- string botnick_t
- spaces
- also_run <- (string "-c" >> spaces >> return False) <|> return True
- delimited <- (oneOf ":," >> spaces >> return True) <|> return False
- let
- wrapProgram c = "#include \"prelude.h\"\n" ++ c ++ "\n"
- wrapPrePost t c = wrapProgram $ "GEORDI_" ++ t ++ "_PRE " ++ c ++ "\nGEORDI_" ++ t ++ "_POST"
- code <- foldr1 (<|>) $
- [ wrapPrePost "PRINT" . (string "<<" >> getInput),
- wrapPrePost "STATEMENTS" . ('{':) . (char '{' >> getInput) ] ++
- if delimited then [wrapProgram . getInput] else []
- return (also_run, code)
+data Flag = CompileOnly | Terse | Help deriving (Eq, Enum, Bounded, Show)
+
+options :: [OptDescr Flag]
+options = (\e -> let s = toLower . show e in Option [head s] [s] (NoArg e) undefined) . [minBound ..]
+
+wrapPrePost :: String -> String -> String
+wrapPrePost t c = "GEORDI_" ++ t ++ "_PRE " ++ c ++ "\nGEORDI_" ++ t ++ "_POST"
+
+wrapPrint, wrapStmts :: String -> String
+wrapPrint = wrapPrePost "PRINT"
+wrapStmts = wrapPrePost "STATEMENTS"
+
+is_request :: String -> String -> Maybe String
+is_request botnick txt = either (const Nothing) Just (parse p "" txt)
+ where
+ p = do
+ string botnick <|> string (capitalize botnick)
+ (oneOf ":," >> getInput) <|> (spaces >> satisfy (not . isLetter) >>= \c -> (c:) . getInput)
+
+parse_request :: Monad m => String -> m (Bool {- also run -}, String {- code -})
+parse_request s = do
+ (opts, nonopcount) <- case getOpt RequireOrder options (words s) of
+ (_, _, (e:_)) -> fail e
+ (f, o, []) -> return (f, length o)
+ code <- if Help `elem` opts then return $ wrapPrint "help" else do
+ let u = concat $ takeBack nonopcount $ wordsWithWhite s
+ case stripPrefix "<<" u of
+ Just r -> return $ wrapPrint r
+ Nothing -> maybe (return u) (return . wrapStmts . ('{':)) (stripPrefix "{" u)
+ return (Help `elem` opts || not (CompileOnly `elem` opts),
+ unlines $ ["#include \"prelude.h\""] ++ (if Terse `elem` opts then ["#include \"terse.hpp\""] else []) ++ [code])
+
+prompt :: String
+prompt = "\n> "
main :: IO ()
main = do
@@ -87,19 +104,18 @@ main = do
eval <- evalCpp
args <- getArgs
let
- localEval l =
- case parse (cmd_parser $ nick cfg) "" l of
- Left e -> putStrLn $ "parse error: " ++ show e
- Right (also_run, code) -> putStrLn =<< filter isPrint . eval code also_run
+ evalRequest :: String -> IO String
+ evalRequest = either return (\(also_run, code) -> filter isPrint . eval code also_run) . parse_request
+
case args of
["-i"] -> do
jail cfg
- forever $ localEval =<< getLine
- [] -> bot cfg eval
- [c] -> jail cfg >> localEval c
+ forever $ putStr prompt >> hFlush stdout >> getLine >>= evalRequest >>= putStrLn
+ [] -> bot cfg evalRequest
+ [c] -> jail cfg >> evalRequest c >>= putStrLn
_ -> fail "Invalid set of command line arguments."
-bot :: BotConfig -> (String -> Bool -> IO String) -> IO ()
+bot :: BotConfig -> (String -> IO String) -> IO ()
bot cfg eval = withResource (connectTo (server cfg) (PortNumber (fromIntegral $ port cfg))) $ \h -> do
setEnv "LC_ALL" "C" True -- Otherwise compiler warnings may use non-ASCII characters (e.g. for quotes).
jail cfg
@@ -110,16 +126,14 @@ bot cfg eval = withResource (connectTo (server cfg) (PortNumber (fromIntegral $
forever $ parse_irc_msg . init . liftIO (hGetLine h) >>= \m -> case m of
IRCmsg _ "PING" a -> cmd "PONG" a
IRCmsg (Just (IRCid fromnick _ _)) "PRIVMSG" [c, txt] ->
- when (elem c (chans cfg) && not (elem fromnick $ blacklist cfg)) $ do
- case parse (cmd_parser $ nick cfg) "" txt of
- Left _ -> return () -- Parse error
- Right (also_run, code) -> do
- o <- take (max_msg_length cfg) . filter isPrint . takeWhile (/= '\n') . eval code also_run
- cmd "PRIVMSG" [c, if null o then no_output_msg cfg else o]
+ when (elem c (chans cfg) && not (elem fromnick $ blacklist cfg)) $
+ maybeM (is_request (nick cfg) txt) $ \r -> do
+ o <- take (max_msg_length cfg) . filter isPrint . takeWhile (/= '\n') . eval r
+ cmd "PRIVMSG" [c, if null o then no_output_msg cfg else o]
IRCmsg _ "376" {- End of motd. -} _ -> do
forM_ (chans cfg) $ cmd "JOIN" . (:[])
maybeM (nick_pass cfg) $ \np -> cmd "PRIVMSG" ["NickServ", "identify " ++ np]
_ -> return ()
--- (filter isPrint) works properly because (1) evalCpp returns a proper Unicode String, not a load of bytes; and (2) we use System.IO.UTF8's hPutStrLn which properly UTF-8 encodes the filtered String.
+-- (filter isPrint) works properly because (1) eval returns a proper Unicode String, not a load of bytes; and (2) we use System.IO.UTF8's hPutStrLn which properly UTF-8 encodes the filtered String.
-- Possible problem: terminals which have not been (properly) UTF-8 configured might interpret bytes that are part of UTF-8 encoded characters as control characters.
View
22 src/Util.hs
@@ -4,15 +4,16 @@ module Util where
import Foreign.C
import Prelude hiding (catch, (.))
import Data.List
+import Data.Char
import Control.Exception
-import System.Posix.IO
import Control.Monad
import Control.Applicative
import Control.Monad.Instances
import System.Posix.Types
+import System.Posix.Resource
+import System.Posix.IO
import System.IO
import GHC.Read
-import System.Posix.Resource
(.) :: Functor f => (a -> b) -> f a -> f b
(.) = fmap
@@ -61,3 +62,20 @@ readTypedFile f = either (const $ fail $ "parsing \"" ++ f ++ "\"") return =<< r
simpleResourceLimits :: Integer -> ResourceLimits
simpleResourceLimits l = ResourceLimits (ResourceLimit l) (ResourceLimit l)
+
+stripPrefix :: String -> String -> Maybe String
+stripPrefix [] ys = Just ys
+stripPrefix (x:xs) (y:ys) | x == y = stripPrefix xs ys
+stripPrefix _ _ = Nothing
+
+capitalize :: String -> String
+capitalize "" = ""
+capitalize (x:xs) = toUpper x : xs
+
+takeBack :: Int -> [a] -> [a]
+takeBack n = reverse . take n . reverse
+
+wordsWithWhite :: String -> [String]
+wordsWithWhite "" = []
+wordsWithWhite s = (a ++ w) : wordsWithWhite s''
+ where (a,s') = break isSpace s; (w,s'') = span isSpace s'

0 comments on commit fc774c9

Please sign in to comment.