module Network.Yogurt.Utils (
mkTrigger, mkTriggerOnce,
mkAlias, mkArgAlias, mkCommand,
Timer, Interval, mkTimer, mkTimerOnce, rmTimer, isTimerActive,
receive, sendln, echo, echoln, echorln, bell,
Logger, startLogging, stopLogging,
matchMore, matchMoreOn, matchMoreOn'
) where
import Network.Yogurt.Mud
import Control.Concurrent
import Control.Monad
import Data.Time.Format (formatTime)
import System.Locale (defaultTimeLocale)
import Data.Time.LocalTime (getZonedTime)
mkTrigger :: Pattern -> Mud a -> Mud Hook
mkTrigger pat act = mkHook Local pat (matchedLine >>= echo >> act)
mkTriggerOnce :: Pattern -> Mud a -> Mud Hook
mkTriggerOnce pat act = mdo
hook <- mkTrigger pat (act >> rmHook hook)
return hook
mkAlias :: String -> String -> Mud Hook
mkAlias pat subst = mkHook Remote ("^" ++ pat ++ "($| .*$)") $ do
suffix <- group 1
echorln (subst ++ suffix)
mkArgAlias :: String -> ([String] -> String) -> Mud Hook
mkArgAlias pat f = mkHook Remote ("^" ++ pat ++ "($| .*$)") $ do
args <- fmap words (group 1)
echorln (f args)
mkCommand :: String -> Mud a -> Mud Hook
mkCommand pat = mkHook Remote ("^" ++ pat ++ "($| .*$)")
newtype Timer = Timer (Var Bool)
type Interval = Int
mkTimer :: Interval -> Mud a -> Mud Timer
mkTimer interval prog = do
vActive <- mkVar True
let timerCycle :: RunMud -> IO ()
timerCycle runMud = do
threadDelay (1000 * interval)
runMud $ do
active <- readVar vActive
when active (prog >> return ())
again <- runMud (readVar vActive)
when again (timerCycle runMud)
forkWithCallback timerCycle
return (Timer vActive)
mkTimerOnce :: Interval -> Mud a -> Mud Timer
mkTimerOnce interval act = mdo
t <- mkTimer interval (act >> rmTimer t)
return t
rmTimer :: Timer -> Mud ()
rmTimer (Timer vActive) = setVar vActive False
isTimerActive :: Timer -> Mud Bool
isTimerActive (Timer vActive) = readVar vActive
receive :: String -> Mud ()
receive = trigger Local
sendln :: String -> Mud ()
sendln m = trigger Remote (m ++ "\n")
echo :: String -> Mud ()
echo = io Local
echoln :: String -> Mud ()
echoln m = echo (m ++ "\n")
echorln :: String -> Mud ()
echorln m = io Remote (m ++ "\n")
bell :: Mud ()
bell = echo "\BEL"
type Logger = (Hook, Hook)
startLogging :: String -> Mud Logger
startLogging name = do
suffix <- liftIO $ fmap (formatTime defaultTimeLocale "-%Y%m%d-%H%M.log") getZonedTime
let filename = name ++ suffix
let record dest = mkPrioHook 100 dest "^" $ do
line <- matchedLine
liftIO $ appendFile filename line
matchMore
r <- record Remote
l <- record Local
return (r, l)
stopLogging :: Logger -> Mud ()
stopLogging (r, l) = do
rmHook r
rmHook l
matchMore :: Mud ()
matchMore = matchedLine >>= matchMoreOn
matchMoreOn :: String -> Mud ()
matchMoreOn message = do
h <- triggeredHook
triggerJust (> h) (hDestination h) message
matchMoreOn' :: String -> Mud ()
matchMoreOn' message = do
h <- triggeredHook
triggerJust (>= h) (hDestination h) message