esotericbot-0.0.1: Esotericbot/Execution.hs

{-# OPTIONS -XMagicHash -XMultiParamTypeClasses -XRankNTypes #-}
module Esotericbot.Execution ( UnknownPluginContext ( .. ) , KnownPluginContext ( .. ) ) where

import Prelude as P

import Data.Attoparsec as A
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BSC
import Data.ByteString.Unsafe
import Data.List.Stream as L
import Data.Maybe
import Data.Map as M

import Control.Concurrent.STM
import Control.Concurrent

import System.IO

import Esotericbot.IRCCom
import Esotericbot.Safely
import Esotericbot.BSUtils
import Esotericbot.EBTypes
import Esotericbot.Help
import Esotericbot.Chanop

type PluginRun =
   ( String , BSC.ByteString , Maybe BSC.ByteString , Maybe Integer )

-- UserCommand instance for commands to an as-yet-unknown plugin
instance RunnableCommand Command UnknownPluginContext where
   run_command cmds ( UnknownPluginContext h help_str op_str ) = do
      sb <- get
      let cmd = irc_cmd cmds
      if BS.isPrefixOf op_str cmd
         then op_cmd h $ cmds { circ_cmd = BS.drop 2 cmd }
            else do
               isListening <- maybe ( return True ) -- if the sender of the message is not on the listening/not listening list, consider them listening.
                                    id
                                    ( do chan <- irc_chan cmds -- it's my favourite monad *aww*
                                         l_var <- M.lookup chan $ listening sb
                                         return $ liftIO $ atomically $ readTVar l_var
                                    )
               if isListening
                  then
                     if BS.isPrefixOf help_str cmd
                        then get_help h $ cmds { circ_cmd = BS.drop 4 cmd }
                        else execute_unknown h cmds
                  else return ( )

data UnknownPluginContext = -- The unknown plugin context needs a handle, the help string, and the op string, in order to correctly identify a plugin
        UnknownPluginContext Handle BS.ByteString BS.ByteString

instance RunnableCommand PluginCommand KnownPluginContext where
   run_command cmds ( KnownPluginContext h ) =
      execute_known h cmds

-- KnownPluginContext
data KnownPluginContext =
        KnownPluginContext Handle

execute_known :: Handle -> PluginCommand -> SmallBotM ( )
execute_known h icmd =
   let ( _ , eprog ) = parse ( sep_prog_and_input $ plugin icmd ) $ irc_cmd icmd
   in respond icmd h eprog


respond cmd h eprog =
   either ( const $ abuse cmd h )
          ( run_prog cmd h )
          eprog

abuse cmd h = do 
   msg <- liftIO $ ls2bs 36 "You are a blight upon the landscape."#
   priv_msg h cmd msg

execute_unknown :: Handle -> Command -> SmallBotM ( ) 
execute_unknown h cmd = do
   let cmds = irc_cmd cmd
   sb <- get 
   let ( _ , eprog ) = get_prog ( plugins sb ) cmds
   respond cmd h eprog

run_prog :: IRCCommand cmd => cmd -> Handle -> PluginRun -> SmallBotM ( ) 
run_prog cmd h ( proc , prog , minput , mmem ) =
    let input = maybe [ ] 
                      ( ( flip (:) ) [ ] . BSC.unpack ) 
                      minput 
    in
    when_mem mmem $
       safely h cmd proc input prog mmem


-- execute when memory is ready
-- this basically blocks the thread when memory is not free
-- perhaps an explicit queue would be better?
-- Some would argue this should be more atomic and use `retry` but this is without considering that at some point the maximum memory
-- that could be allocated may change ( it _is_ in the StateT monad ) so it is better to explicitely re-enter the function
when_mem :: forall a . Maybe Integer -> SmallBotM a -> SmallBotM a
when_mem mmem f = do
   sb <- get
   maybe f
         ( \ memory_max -> do
            current_mem <- liftIO $ atomically $ readTVar $ vCurrent sb
            Just mem_to_allocate <- child_mem_limit mmem -- validity checking on the config file guarantees this to be the case 
            if current_mem + mem_to_allocate >= memory_max
               then do
                  liftIO yield
                  when_mem mmem f
               else do
                  liftIO $ atomically $ writeTVar ( vCurrent sb ) $ current_mem + mem_to_allocate 
                  res <- f
                  liftIO $ atomically $ do new_mem <- readTVar $ vCurrent sb
                                           writeTVar ( vCurrent sb ) $ new_mem - mem_to_allocate
                  return res
         )
         $ mchildren_mem_limit sb      



get_prog executors =
   parse ( p_cmd executors )

p_cmd executors = do
   e <- chooseFrom executors
   spaces
   return e

chooseFrom langs =
   choices $ L.map lang_choice langs

lang_choice plugin = do 
   choices [ string $ prefix plugin , string $ name plugin ]
   spaces
   sep_prog_and_input plugin


sep_prog_and_input plugin =
   maybe all_prog
         ( \ input_break -> try ( do 
             prog <- manyTill anyWord8 $ string input_break
             spaces
             input <- getInput
             return ( cmd plugin , BS.pack prog , Just input , memuse plugin )
             )
             <|> all_prog
         ) 
         $ input_seperator plugin
   where
   all_prog = do
      prog <- getInput
      return ( cmd plugin , prog , Nothing , memuse plugin )