packages feed

Yogurt (empty) → 0.1

raw patch · 7 files changed

+650/−0 lines, 7 filesdep +basedep +containersdep +mtlsetup-changed

Dependencies added: base, containers, mtl, network, old-locale, process, readline, regex-posix, time

Files

+ LICENSE view
@@ -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 Martijn van Steenbergen nor the+      names of its contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY Martijn van Steenbergen ``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 <copyright holder> 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.
+ Network/Yogurt.hs view
@@ -0,0 +1,8 @@+-- | Re-exports Network.Yogurt.Mud and Network.Yogurt.Engine.+module Network.Yogurt (+  module Network.Yogurt.Mud,+  module Network.Yogurt.Engine+  ) where++import Network.Yogurt.Mud+import Network.Yogurt.Engine
+ Network/Yogurt/Engine.hs view
@@ -0,0 +1,123 @@+module Network.Yogurt.Engine (connect, Environment, Output, runMud) where++import Network.Yogurt.Mud+import System.IO+import Network+import Control.Concurrent+import Control.Monad.State+import System.Console.Readline+import Network.Yogurt.IO+import Data.Char (isSpace)+++-- | Used by 'runMud' to output messages and update the state during execution.+type Environment = (Output, MVar MudState)++-- | Provides a way to output messages.+type Output = Destination -> String -> IO ()++-- | @connect hostname port program@ connects to a MUD and executes the specified program. Input is read from @stdin@, and output is written to @stdout@.+connect :: String -> Int -> Mud () -> IO ()+connect host port mud = do+  -- Connect.+  putStrLn $ "Connecting to " ++ host ++ " port " ++ show port ++ "..."+  h <- connectTo host (PortNumber (fromIntegral port))++  -- Create shared mud state, executing initial commands.+  vState <- newMVar (execState mud emptyMud)++  -- Start child threads.+  let out ch msg = case ch of+        Local  -> writeToTTY msg+        Remote -> do hPutStr h msg; hFlush h+  let env = (out, vState)+  forkIO (handleSource env localInput Remote)+  handleSource env (remoteInput h) Local+++-- Watches an input source and updates the mud state whenever a new message arrives.+handleSource :: Environment ->        -- to run mud computations+                IO (Maybe String) ->  -- input source+                Destination ->        -- target destination+                IO ()+handleSource env input dest = loop where+  loop = do+    mmessage <- input+    case mmessage of+      Nothing -> return ()+      Just message -> do+        runMud env (trigger dest message)+        loop+++-- Local input using readline.+localInput :: IO (Maybe String)+localInput = do+  maybeLine <- readline ""+  setLineBuffer ""+  case maybeLine of+    Nothing   -> return Nothing+    Just line -> do+      when (not $ all isSpace line) (addHistory line)+      return (Just $ line ++ "\n")+++-- Remote input using a connection handle.+remoteInput :: Handle -> IO (Maybe String)+remoteInput h = do+  input <- maybeInput (hGetImpatientLine h 50)+  return input+++-- | Runs a Mud computation, executes the results (such as sending messages to the screen or the MUD) and returns the computation's result. The MVar is updated.+runMud :: Environment -> Mud a -> IO a+runMud env@(_, vState) prog = do+  s1 <- takeMVar vState+  let (rv, s2) = runState prog s1+  let (rs, s3) = runState flushResults s2+  putMVar vState s3+  executeResults env rs+  return rv+++-- Executes results in sequence.+executeResults :: Environment -> [Result] -> IO ()+executeResults env = sequence_ . map (executeResult env)+++-- Executes one result.+executeResult :: Environment -> Result -> IO ()+executeResult env@(out, _) res = case res of++    Send ch msg -> do+      -- debug $ "Send " ++ show ch ++ " " ++ show msg+      out ch msg++    RunIO io actf -> do+      -- debug "RunIO"+      x <- io+      runMud env (actf x)++    NewTimer timer -> do+      -- debug "NewTimer"+      forkIO (runTimer env timer)+      return ()+++-- Called whenever a new timer is created.+runTimer :: Environment -> Timer -> IO ()+runTimer env timer = loop where+  loop = do+    -- Sleep.+    threadDelay (1000 * tInterval timer)  -- interval in ms, threadDelay expects micros++    -- Execute timer action only if timer hasn't been removed in the meantime.+    ok <- runMud env (existsTimer timer)+    when ok (runMud env $ tAction timer)++    -- Maybe the timer's action removed the timer. If not, run again.+    again <- runMud env (existsTimer timer)+    when again loop++debug :: String -> IO ()+debug = appendFile "debug.log" . (++ "\n")
+ Network/Yogurt/Mud.hs view
@@ -0,0 +1,328 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++-- | The core of Yogurt, consisting of the Mud monad and all functions manipulating this monad.+module Network.Yogurt.Mud (++  -- * Types+  Mud, MudState, emptyMud,+  Hook,+  Destination(..),+  Pattern,+  Timer, Interval,+  Result(..),++  -- * Hooks+  -- | A hook watches a channel for messages matching a specific regular expression. When a hook fires, the triggering message is consumed and the hook's action is executed. When a message doesn't trigger any hooks, it is sent on to its destination. A hook's action may query for match-specific data; see section Match Information. At most one hook fires for each message, unless the hook's action explicitly sends the message through 'trigger' again. If several hooks match, only the hook with the highest priority fires. If there is still a tie, the hook that was defined last (using 'mkHook') fires.+  mkHook, mkPrioHook, setHook, rmHook, allHooks,+  +  -- ** Hook record fields+  -- | Use these in combination with 'setHook' to update hooks.+  hPriority, hDestination, hPattern, hAction,++  -- * Match information+  -- | #MatchInformation# Functions for querying the currently firing hook. These functions should only be called from within a hook's body.+  triggeredHook, matchedLine, before, group, after,++  -- * Variables+  mkVar, setVar, readVar, modifyVar,++  -- * Timers+  mkTimer, rmTimer, existsTimer, allTimers,+  -- ** Timer record fields+  tAction, tInterval,++  -- * Triggering hooks+  trigger, triggerJust, io, flushResults,++  -- * IO+  withIO, runIO++  ) where++import Prelude hiding (lookup)+import Data.IntMap (IntMap, empty, insert, delete, lookup, elems, member)+import Unsafe.Coerce+import Text.Regex.Posix+import Network.Yogurt.Ansi+import Control.Monad.State+import Data.List (sort)+import Data.Function (on)+import Data.Ord (comparing)++++-- Section: Types.+++-- | The Mud monad is a simple state monad.+type Mud = State MudState++-- | State internal to the Mud monad.+data MudState = MudState+  { hooks     :: IntMap Hook+  , vars      :: IntMap Opaque+  , timers    :: IntMap Timer+  , supply    :: [Int]+  , matchInfo :: Maybe MatchInfo+  , results   :: [Result]+  }++-- | The initial state of the Mud monad.+emptyMud :: MudState+emptyMud = MudState empty empty empty [0..] Nothing []++-- | The abstract Hook type. Two hooks are considered equal if they were created (using 'mkHook') at the same time. Hook h1 < hook h2 if h1 will match earlier than h2.+data Hook = Hook+  { hId          :: Int+  , hPriority    :: Int          -- ^ Yields the hook's priority. +  , hDestination :: Destination  -- ^ Yields the destination this hook watches.+  , hPattern     :: Pattern      -- ^ Yields the pattern messages must have for this hook to fire.+  , hAction      :: Mud ()       -- ^ Yields the Mud program to execute when the hook fires.+  }++instance Eq Hook where+  h1 == h2 = hId h1 == hId h2++instance Ord Hook where+  compare h1 h2 = rev $+    case compare (hPriority h1) (hPriority h2) of+      EQ -> compare (hId h1) (hId h2)+      x  -> x++rev :: Ordering -> Ordering+rev x = case x of+  LT -> GT+  EQ -> EQ+  GT -> LT++instance Show Hook where+  show (Hook hid prio dest pat _) = "Hook #" ++ show hid ++ " @" ++ show prio ++ " " ++ show dest ++ " [" ++ pat ++ "]"++-- | Used to distinguish between messages going in different directions.+data Destination+  = Local   -- ^ The message is headed towards the user's terminal.+  | Remote  -- ^ The message is headed towards the remote MUD server.+  deriving (Eq, Show, Read, Enum, Ord)++-- | A Pattern is a regular expression.+type Pattern = String++data MatchInfo = MatchInfo+  { mTriggeredHook :: Hook+  , mMatchedLine   :: String+  , mBefore        :: String+  , mGroups        :: [String]+  , mAfter         :: String+  }++-- | Variables hold temporary, updatable, typed data.+data Var a = Var Int++data Opaque = forall a. Opaque a++-- Timers.+-- | The abstract Timer type.+data Timer = Timer+  { tId     :: Int+  , tAction :: Mud ()      -- ^ Yields the timer's action.+  , tInterval :: Interval  -- ^ Yields the timer's interval.+  }++-- | Interval in milliseconds.+type Interval = Int++-- | A @Result@ is a consequence of executing a @Mud@ program.+data Result+  = Send Destination String  -- no implicit newlines!+  | forall a. RunIO (IO a) (a -> Mud ())+  | NewTimer Timer++++-- Section: Helper functions for querying and manipulating state.+++mkId :: Mud Int+mkId = do+  i <- gets (head . supply)+  modify $ \s -> s { supply = tail (supply s) }+  return i++updateHooks :: (IntMap Hook -> IntMap Hook) -> Mud ()+updateHooks f = modify $ \s -> s { hooks = f (hooks s) }++updateVars :: (IntMap Opaque -> IntMap Opaque) -> Mud ()+updateVars f = modify $ \s -> s { vars = f (vars s) }++updateTimers :: (IntMap Timer -> IntMap Timer) -> Mud ()+updateTimers f = modify $ \s -> s { timers = f (timers s) }++addResult :: Result -> Mud ()+addResult r = modify $ \s -> s { results = results s ++ [r] }++-- | Yields all accumulated results and removes them from the state. Used by "Network.Yogurt.Engine" in @runMud@.+flushResults :: Mud [Result]+flushResults = do+  rs <- gets results+  modify $ \s -> s { results = [] }+  return rs++++-- Section: Hooks.+++-- | Calls 'mkPrioHook' with priority 0.+mkHook :: Destination -> Pattern -> Mud a -> Mud Hook+mkHook = mkPrioHook 0++-- | Creates and installs a hook that watches messages headed to the specified destination and match the specified pattern.+mkPrioHook :: Int -> Destination -> Pattern -> Mud a -> Mud Hook+mkPrioHook prio dest pat act = do+  hid <- mkId+  let hook = Hook hid prio dest pat (act >> return ())+  setHook hook+  return hook++-- | Saves a changed hook, or reactivates it.+setHook :: Hook -> Mud ()+setHook hook = updateHooks $ insert (hId hook) hook++-- | Disables a hook.+rmHook :: Hook -> Mud ()+rmHook = updateHooks . delete . hId++-- | Yields all current hooks in preferred firing order.+allHooks :: Mud [Hook]+allHooks = gets (sort . elems . hooks)++++-- Section: MatchInfo.+++setMatchInfo :: Maybe MatchInfo -> Mud ()+setMatchInfo mi = modify $ \s -> s { matchInfo = mi }++getMatchInfo :: Mud MatchInfo+getMatchInfo = do+  mi <- gets matchInfo+  case mi of+    Nothing  -> fail "No match is available."+    Just mi' -> return mi'++-- | Yields the hook that is currently firing.+triggeredHook :: Mud Hook+triggeredHook = fmap mTriggeredHook getMatchInfo++-- | Yields the message that triggered the currently firing hook.+matchedLine :: Mud String+matchedLine = fmap mMatchedLine getMatchInfo++-- | Yields the part of the triggering message that comes before the matched pattern.+before :: Mud String+before = fmap mBefore getMatchInfo++-- | Yields the regex group from the matched pattern. @group 0@ yields the complete match; higher indices correspond to the parenthesized groups.+group :: Int -> Mud String+group n = fmap ((!! n) . mGroups) getMatchInfo++-- | Yields the part of the triggering message that comes after the matched pattern.+after :: Mud String+after = fmap mAfter getMatchInfo+++-- Section: Variables.++-- | Creates a variable with an initial value.+mkVar :: a -> Mud (Var a)+mkVar val = do+  i <- mkId+  setVar (Var i) val+  return (Var i)++-- | Updates a variable to a new value.+setVar :: Var a -> a -> Mud ()+setVar (Var i) val = updateVars $ insert i (Opaque val)++-- | Yields the variable's current value.+readVar :: Var a -> Mud a+readVar (Var i) = do+  varmap <- gets vars+  Opaque val <- lookup i varmap+  return (unsafeCoerce val)++-- | Updates the variable using the update function.+modifyVar :: Var a -> (a -> a) -> Mud ()+modifyVar var f = readVar var >>= setVar var . f++++-- Section: Timers.+++-- | @mkTimer interval prog@ creates a timer that executes @prog@ every @interval@ milliseconds.+mkTimer :: Interval -> Mud a -> Mud Timer+mkTimer interval prog = do+  i <- mkId+  let timer = Timer i (prog >> return ()) interval+  updateTimers $ insert i timer+  addResult (NewTimer timer)+  return timer++-- | Disables the timer.+rmTimer :: Timer -> Mud ()+rmTimer = updateTimers . delete . tId++-- | Checks whether a timer is active.+existsTimer :: Timer -> Mud Bool+existsTimer (Timer ti _ _) = gets (member ti . timers)++-- | Yields all currently active timers.+allTimers :: Mud [Timer]+allTimers = gets (elems . timers)++++-- Section: Triggering hooks++-- | Short for @'triggerJust' (const True)@.+trigger :: Destination -> String -> Mud ()+trigger = triggerJust (const True)++-- | If the message triggers a hook that passes the specified test, it is fired. Otherwise, the message is passed on to the destination using 'io'.+triggerJust :: (Hook -> Bool) -> Destination -> String -> Mud ()+triggerJust test dest message = do+    hs <- allHooks+    case filter ok hs of+      []       -> io dest message+      (hook:_) -> fire message hook+  where+    ok hook = test hook && hDestination hook == dest && rmAnsi message =~ hPattern hook++-- | Executes the hook's action based on the matching message.+fire :: String -> Hook -> Mud ()+fire message hook = do+    oldMatchInfo <- gets matchInfo+    setMatchInfo $ Just $ MatchInfo hook message before (match : groups) after+    hAction hook+    setMatchInfo oldMatchInfo+  where+    (before, match, after, groups) = rmAnsi message =~ hPattern hook :: (String, String, String, [String])++-- | Immediately write a message to a destination, without triggering hooks.+io :: Destination -> String -> Mud ()+io ch message = addResult (Send ch message)++++-- Section: IO.+++-- | Invokes withIO, discarding the IO's result.+runIO :: IO a -> Mud ()+runIO io = withIO io (const $ return ())++-- | Executes the IO action soon. The computation's result is passed to the function, and the resulting Mud computation is executed.+withIO :: IO a -> (a -> Mud ()) -> Mud ()+withIO io act = addResult (RunIO io act)
+ Network/Yogurt/Utils.hs view
@@ -0,0 +1,147 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++-- | Convenience functions on top of "Yogurt.Mud".+module Network.Yogurt.Utils (+  -- * Re-exports+  module Network.Yogurt.Mud,++  -- * Hook and timer derivatives+  mkTrigger, mkTriggerOnce,+  mkAlias, mkArgAlias, mkCommand,+  mkTimerOnce,++  -- * Sending messages+  receive, sendln, echo, echoln, echorln, bell,++  -- * Logging+  Logger, startLogging, stopLogging,++  -- * Miscellaneous+  matchMore, matchMoreOn, matchMoreOn',+  system++  ) where++import Network.Yogurt.Mud+import qualified System.Cmd as Cmd+import System.IO.Unsafe+import Data.Time.Format (formatTime)+import System.Locale (defaultTimeLocale)+import Data.Time.LocalTime (getZonedTime)++++-- Hook and timer derivatives.+++-- | Creates a hook that watches messages headed to the terminal. When fired, the message is passed on to the terminal and the action is executed.+mkTrigger :: Pattern -> Mud a -> Mud Hook+mkTrigger pat act = mkHook Local pat (matchedLine >>= echo >> act)++-- | Like 'mkTrigger', but fires at most once.+mkTriggerOnce :: Pattern -> Mud a -> Mud Hook+mkTriggerOnce pat act = mdo  -- whoo! recursive monads!+  hook <- mkTrigger pat (act >> rmHook hook)+  return hook++-- | @mkAlias command subst@ creates a hook that watches messages headed to the remote MUD. If the message is or starts with the word @command@, the command is replaced by @subst@ before being sent to the MUD.+mkAlias :: String -> String -> Mud Hook+mkAlias pat subst = mkHook Remote ("^" ++ pat ++ "($| .*$)") $ do+  suffix <- group 1+  echorln (subst ++ suffix)++-- | Like 'mkAlias', @mkArgAlias command subst@ creates a hook that watches messages headed to the remote MUD. But here the whole message is substituted instead of just the first command word, and the substitution depends on the command's arguments.+mkArgAlias :: String -> ([String] -> String) -> Mud Hook+mkArgAlias pat f = mkHook Remote ("^" ++ pat ++ "($| .*$)") $ do+  args <- fmap words (group 1)+  echorln (f args)++-- | Like 'mkAlias', but instead of substituting the command, a program is executed.+mkCommand :: String -> Mud a -> Mud Hook+mkCommand pat = mkHook Remote ("^" ++ pat ++ "($| .*$)")++-- | Creates a timer that fires only once.+mkTimerOnce :: Interval -> Mud a -> Mud Timer+mkTimerOnce interval act = mdo+  t <- mkTimer interval (act >> rmTimer t)+  return t++++-- Sending messages.+++-- | Sends a message to the terminal, triggering hooks.+receive :: String -> Mud ()+receive = trigger Local++-- | Sends a message appended with a newline character to the MUD, triggering hooks.+sendln :: String -> Mud ()+sendln m = trigger Remote (m ++ "\n")++-- | Sends a message to the terminal, without triggering hooks.+echo :: String -> Mud ()+echo = io Local++-- | Sends a message appended with a newline character to the terminal, without triggering hooks.+echoln :: String -> Mud ()+echoln m = echo (m ++ "\n")++-- | Sends a message appended with a newline character to the MUD, without triggering hooks.+echorln :: String -> Mud ()+echorln m = io Remote (m ++ "\n")++-- | Sends a bell character to the terminal.+bell :: Mud ()+bell = echo "\BEL"++++-- Logging.++type Logger = (Hook, Hook)  -- Remote, Local++-- | @startLogging name@ causes all messages to be logged in a file called @name-yyyymmdd-hhmm.log@. The used hooks have priority 100.+startLogging :: String -> Mud Logger+startLogging name = do+  let suffix = unsafePerformIO $+        fmap (formatTime defaultTimeLocale "-%Y%m%d-%H%M.log") getZonedTime+  let filename = name ++ suffix+  let record dest = mkPrioHook 100 dest "^" $ do+        line <- matchedLine+        runIO (appendFile filename line)+        matchMore+  r <- record Remote+  l <- record Local+  return (r, l)++-- | Stops the logger.+stopLogging :: Logger -> Mud ()+stopLogging (r, l) = do+  rmHook r+  rmHook l++++-- Miscellaneous.+++-- | When called from a hook body, gives hooks that haven't been considered yet a chance to match on the currently triggering message. Useful if you want to build a hook that only has a side-effect and doesn't want to directly affect the other active hooks.+matchMore :: Mud ()+matchMore = matchedLine >>= matchMoreOn++-- | Like 'matchMore', but allows specification of the message that is passed on.+matchMoreOn :: String -> Mud ()+matchMoreOn message = do+  h <- triggeredHook+  triggerJust (> h) (hDestination h) message++-- | Like 'matchMoreOn', but also makes the currently firing hook eligible for firing again.+matchMoreOn' :: String -> Mud ()+matchMoreOn' message = do+  h <- triggeredHook+  triggerJust (>= h) (hDestination h) message++-- | Executes a shell command.+system :: String -> Mud ()+system = runIO . Cmd.system
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ Yogurt.cabal view
@@ -0,0 +1,17 @@+Name:           Yogurt+Version:        0.1+Cabal-Version:  >= 1.2+License:        BSD3+License-file:   LICENSE+Author:         Martijn van Steenbergen+Maintainer:     martijn@van.steenbergen.nl+Copyright:	Copyright (c) 2008 Martijn van Steenbergen+Description:    A MUD client library for Haskell. Features prioritized, regex-based hooks, variables and timers.+Synopsis:	A MUD client library+Homepage:       http://martijn.van.steenbergen.nl/projects/yogurt/+Category:       Network+Build-type:     Simple++Library+  Build-Depends:    base, mtl, regex-posix, containers, time, old-locale, process, readline, network+  Exposed-modules:  Network.Yogurt, Network.Yogurt.Mud, Network.Yogurt.Utils, Network.Yogurt.Engine