diff --git a/Examples/Minimal.hs b/Examples/Minimal.hs new file mode 100644 --- /dev/null +++ b/Examples/Minimal.hs @@ -0,0 +1,9 @@ +module Minimal where + +import Network.Yogurt + +newmoon :: Session +newmoon = session + { hostName = "eclipse.cs.pdx.edu" + , portNumber = 7680 + } diff --git a/Examples/NewMoon.hs b/Examples/NewMoon.hs new file mode 100644 --- /dev/null +++ b/Examples/NewMoon.hs @@ -0,0 +1,71 @@ +module NewMoon where + +import Network.Yogurt +import System.Cmd +import Data.Char + +newmoon :: Session +newmoon = session + { hostName = "eclipse.cs.pdx.edu" + , portNumber = 7680 + , mudProgram = \reload -> do + -- The reload argument allows reloading this Haskell file during a session. + -- Let's make a command for it so we can call it while playing. + mkCommand "reload" reload + installHooks + } + +installHooks :: Mud () +installHooks = do + -- Logs are stored in a timestamped file in the local directory. + startLogging "NewMoon" + + -- Log in automatically. + mkTriggerOnce "^Enter your name:" $ do + sendln "username" + sendln "password" + + -- Sound system bell whenever you receive a tell. + mkTrigger "^[^ ]+ tells you: " bell + + -- Send a carriage return every 5 minutes to keep the connection alive. + -- Most MUDs don't like this... + mkTimer (5 * 60 * 1000) (sendln "") + + -- Enable calling system commands during a session. + mkCommand "system" $ do + group 1 >>= liftIO . system + return () + + -- | Split commands in two on semicolons. + mkPrioHook 100 Remote ";" $ do + before >>= matchMoreOn . (++ "\n") + after >>= matchMoreOn' + + -- Enable speedwalks, e.g. "5w" expands to "w;w;w;w;w" + mkHook Remote "^[0-9]+[neswud]$" $ do + (n, dir) <- fmap (span isDigit) (group 0) + sequence $ replicate (read n) (sendln dir) + + -- A very simple alias: make "fb" expand to "cast fireball" + mkAlias "fb" "cast fireball" + + -- Create a command to teleport to a specific place. + mkCommand "tp" $ do + -- Find out where to go. + dest <- group 1 + if all isSpace dest + then do + echoln "Teleport to where?" + else do + sendln "cast teleport" + + -- Wait for the spell to get ready... + mkTriggerOnce "^You feel ready to teleport now" $ do + sendln ("teleport to" ++ dest) + return () + + -- Show all currently install hooks whenever "hooks" is entered. + mkCommand "hooks" (allHooks >>= echo . unlines . map show) + + return () diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2008, Martijn van Steenbergen +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 the author nor the + names of his contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/Yogurt-Standalone.cabal b/Yogurt-Standalone.cabal new file mode 100644 --- /dev/null +++ b/Yogurt-Standalone.cabal @@ -0,0 +1,34 @@ +Name: Yogurt-Standalone +Version: 0.4 +Synopsis: A functional MUD client +Description: Yogurt is a functional MUD client featuring prioritized, regex-based hooks, variables, timers, logging, dynamic loading of Yogurt scripts and more. For example programs, please see Yogurt's home page. + . + This is the standalone executable built on top of the Yogurt library. Invoke @yogurt@ on a Haskell file that defines one or more sessions to have it load that module and connect to the specified MUD. See module @Network.Yogurt.Session@ in package Yogurt for more details. + + +Author: Martijn van Steenbergen +Maintainer: martijn@van.steenbergen.nl +Stability: Experimental +Copyright: Some Rights Reserved (CC) 2008-2009 Martijn van Steenbergen +Homepage: http://code.google.com/p/yogurt-mud/ + + +Cabal-Version: >= 1.2 +License: BSD3 +License-file: LICENSE +Category: Network +Build-type: Simple +Extra-Source-Files: Examples/Minimal.hs, Examples/NewMoon.hs + + +Executable yogurt + Main-Is: YogurtExec.hs + GHC-Options: -threaded + Build-Depends: mtl, regex-posix, containers, time, old-locale, Yogurt, network, process, hint + Extra-Libraries: readline + + if impl(ghc >= 6.10) { + Build-Depends: base >= 4, base < 5, syb + } else { + Build-Depends: base >= 3, base < 4 + } diff --git a/YogurtExec.hs b/YogurtExec.hs new file mode 100644 --- /dev/null +++ b/YogurtExec.hs @@ -0,0 +1,151 @@ +import Network.Yogurt +import Network.Yogurt.Readline + +import System.Exit +import System.Environment +import System.Console.GetOpt +import System.IO +import Data.List +import Data.Function +import Data.Version +import Control.Monad +import Control.Monad.Trans +import qualified Paths_Yogurt_Standalone as P + +import Language.Haskell.Interpreter + +options :: [OptDescr (IO ())] +options = + [ Option "v" ["version"] (NoArg (printVersion >> exitSuccess)) "print version and exit" + , Option "h" ["help"] (NoArg (printHelp >> exitSuccess)) "print help and exit" + ] + +main :: IO () +main = do + (flags, otherArgs, errs) <- getOpt RequireOrder options `liftM` getArgs + let flatErrs = filter (not . null) $ concatMap (lines . indent) errs + + unless (null flatErrs) $ do + errLn $ "Illegal arguments:" + err $ unlines flatErrs + errLn $ "Try yogurt --help for help." + exitFailure + + sequence_ flags + case otherArgs of + [moduleName] -> + loadSession moduleName pickDefaultSession + [moduleName, sessionName] -> + loadSession moduleName (pickSession sessionName) + _ -> + printUsage >> exitFailure + +-- moduleName -> available session names -> session name to load +type PickSession = String -> [String] -> IO String + +pickDefaultSession :: PickSession +pickDefaultSession moduleName sessionNames = do + case sessionNames of + [] -> do + errLn $ "Module " ++ moduleName ++ " defines no sessions." + exitFailure + [sessionName] -> do + return sessionName + _ -> do + errLn $ "Module " ++ moduleName ++ " defines several sessions: " ++ intercalate ", " sessionNames + errLn $ "Use \"yogurt " ++ moduleName ++ " \" to pick a specific session." + exitFailure + +pickSession :: String -> PickSession +pickSession sessionName moduleName sessionNames = do + if sessionName `elem` sessionNames + then return sessionName + else do + errLn $ "Module " ++ moduleName ++ " defines no session called \"" ++ sessionName ++ "\"." + exitFailure + +indent :: String -> String +indent = unlines . map (" " ++ ) . lines + +loadSession :: String -> PickSession -> IO () +loadSession moduleName pick = do + errLn $ "Loading module " ++ moduleName ++ "..." + mSessions <- loadPlugin moduleName + case mSessions of + Left e -> do + errLn (pretty e) + exitFailure + Right sessions -> do + sessionName <- pick moduleName (map fst sessions) + let Just session = lookup sessionName sessions + let doReload = reload moduleName sessionName + connect (hostName session) (portNumber session) (mudProgram session doReload) + +printUsage :: IO () +printUsage = do + errLn $ "Usage: yogurt []" + errLn $ " or: yogurt --help" + +printVersion :: IO () +printVersion = do + errLn $ "Yogurt version " ++ showVersion P.version + errLn $ "Using version " ++ showVersion version ++ " of the Yogurt library" + errLn $ "Some Rights Reserved (CC) 2008-2009 Martijn van Steenbergen" + errLn $ "http://martijn.van.steenbergen.nl/projects/yogurt/" + +printHelp :: IO () +printHelp = do + printVersion + errLn $ "" + errLn $ "Usage: yogurt []" + errLn $ "" + err $ usageInfo "Available options:" options + +err :: String -> IO () +err = hPutStr stderr + +errLn :: String -> IO () +errLn = hPutStrLn stderr + +pretty :: InterpreterError -> String +pretty e = case e of + UnknownError s -> s + WontCompile ss -> intercalate "\n\n" (map errMsg ss) + NotAllowed s -> s + GhcException s -> s + +reload :: String -> String -> Mud () +reload moduleName sessionName = fix $ \loop -> do + echoln $ "Loading module " ++ moduleName ++ "..." + mSessions <- lift $ loadPlugin moduleName + case mSessions of + Left e -> echoln (pretty e) + Right sessions -> do + case lookup sessionName sessions of + Nothing -> do + echoln $ "Module " ++ moduleName ++ + " no longer contains a session called \"" ++ sessionName ++ "\"." + Just session -> do + mapM_ rmHook =<< allHooks + mudProgram session loop + echoln "Done." + +-- | Given a module name, yields all sessions and their names defined in that module. +loadPlugin :: String -> IO (Either InterpreterError [(String, Session)]) +loadPlugin mn = runInterpreter $ do + let moduleName = case elemIndices '.' mn of + [] -> mn + is -> take (last is) mn + loadModules [moduleName] + loadedModuleNames <- getLoadedModules + if not (moduleName `elem` loadedModuleNames) + then do + fail "The module's name must match the filename." + else do + setImports ["Network.Yogurt.Session", moduleName] + symbols <- map name `liftM` getModuleExports moduleName + typedSymbols <- mapM (\s -> (,) `liftM` return s `ap` typeOf s) symbols + let sessionNames = [ n | (n, t) <- typedSymbols, t == "Session" ] + forM sessionNames $ \sn -> do + session <- interpret sn (as :: Session) + return (sn, session)