-- | Offline mode / RC file / -e support module.  Handles spooling lists
-- of commands (from haskeline, files, or the command line) into the vchat
-- layer.
module Lambdabot.Plugin.Core.OfflineRC ( offlineRCPlugin ) where

import Lambdabot.Config.Core
import Lambdabot.IRC
import Lambdabot.Monad
import Lambdabot.Plugin
import Lambdabot.Util

import Control.Concurrent.Lifted
import Control.Exception.Lifted ( evaluate, finally )
import Control.Monad( void, when )
import Control.Monad.State( gets, modify )
import Control.Monad.Trans( lift, liftIO )
import Data.Char
import qualified Data.Map as M
import qualified Data.Set as S
import System.Console.Haskeline (InputT, Settings(..), runInputT, defaultSettings, getInputLine)
import System.IO
import System.Timeout.Lifted
import Codec.Binary.UTF8.String

-- We need to track the number of active sourcings so that we can
-- unregister the server (-> allow the bot to quit) when it is not
-- being used.
type OfflineRCState = Integer
type OfflineRC = ModuleT OfflineRCState LB

offlineRCPlugin :: Module OfflineRCState
offlineRCPlugin :: Module OfflineRCState
offlineRCPlugin = Module OfflineRCState
forall st. Module st
newModule
    { moduleDefState = return 0
    , moduleInit = do
        lb . modify $ \IRCRWState
s -> IRCRWState
s
            { ircPrivilegedUsers = S.insert (Nick "offlinerc" "null") (ircPrivilegedUsers s)
            }
        -- note: moduleInit is invoked with exceptions masked
        void . forkUnmasked $ do
            waitForInit
            lockRC
            cmds <- getConfig onStartupCmds
            mapM_ feed cmds `finally` unlockRC

    , moduleCmds = return
        [ (command "offline")
            { privileged = True
            , help = say "offline. Start a repl"
            , process = const . lift $ do
                lockRC
                histFile <- lb $ findLBFileForWriting "offlinerc"
                let settings = Settings (ModuleT OfflineRCState LB)
forall (m :: * -> *). MonadIO m => Settings m
defaultSettings { historyFile = Just histFile }
                _ <- fork (runInputT settings replLoop `finally` unlockRC)
                return ()
            }
        , (command "rc")
            { privileged = True
            , help = say "rc name. Read a file of commands (asynchronously). TODO: better name."
            , process = \String
fn -> ModuleT OfflineRCState LB () -> Cmd (ModuleT OfflineRCState LB) ()
forall (m :: * -> *) a. Monad m => m a -> Cmd m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ModuleT OfflineRCState LB ()
 -> Cmd (ModuleT OfflineRCState LB) ())
-> ModuleT OfflineRCState LB ()
-> Cmd (ModuleT OfflineRCState LB) ()
forall a b. (a -> b) -> a -> b
$ do
                txt <- IO String -> ModuleT OfflineRCState LB String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO String -> ModuleT OfflineRCState LB String)
-> IO String -> ModuleT OfflineRCState LB String
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
fn
                io $ evaluate $ foldr seq () txt
                lockRC
                _ <- fork (mapM_ feed (lines txt) `finally` unlockRC)
                return ()
            }
        ]
    }

feed :: String -> OfflineRC ()
feed :: String -> ModuleT OfflineRCState LB ()
feed String
msg = do
    cmdPrefix <- ([String] -> String)
-> ModuleT OfflineRCState LB [String]
-> ModuleT OfflineRCState LB String
forall a b.
(a -> b)
-> ModuleT OfflineRCState LB a -> ModuleT OfflineRCState LB b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> String
forall a. HasCallStack => [a] -> a
head (Config [String] -> ModuleT OfflineRCState LB [String]
forall a. Config a -> ModuleT OfflineRCState LB a
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
commandPrefixes)
    let msg' = case String
msg of
            Char
'>':String
xs -> String
cmdPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"run " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
xs
            Char
'!':String
xs -> String
xs
            String
_      -> String
cmdPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') String
msg
    -- note that `msg'` is unicode, but lambdabot wants utf-8 lists of bytes
    lb . void . timeout (15 * 1000 * 1000) . received $
              IrcMessage { ircMsgServer = "offlinerc"
                         , ircMsgLBName = "offline"
                         , ircMsgPrefix = "null!n=user@null"
                         , ircMsgCommand = "PRIVMSG"
                         , ircMsgParams = ["offline", ":" ++ encodeString msg' ] }

handleMsg :: IrcMessage -> OfflineRC ()
handleMsg :: IrcMessage -> ModuleT OfflineRCState LB ()
handleMsg IrcMessage
msg = IO () -> ModuleT OfflineRCState LB ()
forall a. IO a -> ModuleT OfflineRCState LB a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ModuleT OfflineRCState LB ())
-> IO () -> ModuleT OfflineRCState LB ()
forall a b. (a -> b) -> a -> b
$ do
    let str :: String
str = case ([String] -> [String]
forall a. HasCallStack => [a] -> [a]
tail ([String] -> [String])
-> (IrcMessage -> [String]) -> IrcMessage -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IrcMessage -> [String]
ircMsgParams) IrcMessage
msg of
            []    -> []
            (String
x:[String]
_) -> String -> String
forall a. HasCallStack => [a] -> [a]
tail String
x
    -- str contains utf-8 list of bytes; convert to unicode
    Handle -> String -> IO ()
hPutStrLn Handle
stdout (String -> String
decodeString String
str)
    Handle -> IO ()
hFlush Handle
stdout

replLoop :: InputT OfflineRC ()
replLoop :: InputT (ModuleT OfflineRCState LB) ()
replLoop = do
    line <- String -> InputT (ModuleT OfflineRCState LB) (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine String
"lambdabot> "
    case line of
        Maybe String
Nothing -> () -> InputT (ModuleT OfflineRCState LB) ()
forall a. a -> InputT (ModuleT OfflineRCState LB) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just String
x -> do
            let s' :: String
s' = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
x
            Bool
-> InputT (ModuleT OfflineRCState LB) ()
-> InputT (ModuleT OfflineRCState LB) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s') (InputT (ModuleT OfflineRCState LB) ()
 -> InputT (ModuleT OfflineRCState LB) ())
-> InputT (ModuleT OfflineRCState LB) ()
-> InputT (ModuleT OfflineRCState LB) ()
forall a b. (a -> b) -> a -> b
$ do
                ModuleT OfflineRCState LB ()
-> InputT (ModuleT OfflineRCState LB) ()
forall (m :: * -> *) a. Monad m => m a -> InputT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ModuleT OfflineRCState LB ()
 -> InputT (ModuleT OfflineRCState LB) ())
-> ModuleT OfflineRCState LB ()
-> InputT (ModuleT OfflineRCState LB) ()
forall a b. (a -> b) -> a -> b
$ String -> ModuleT OfflineRCState LB ()
feed String
s'
            continue <- OfflineRC Bool -> InputT (ModuleT OfflineRCState LB) Bool
forall (m :: * -> *) a. Monad m => m a -> InputT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (OfflineRC Bool -> InputT (ModuleT OfflineRCState LB) Bool)
-> OfflineRC Bool -> InputT (ModuleT OfflineRCState LB) Bool
forall a b. (a -> b) -> a -> b
$ LB Bool -> OfflineRC Bool
forall (m :: * -> *) a.
Monad m =>
m a -> ModuleT OfflineRCState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LB Bool -> OfflineRC Bool) -> LB Bool -> OfflineRC Bool
forall a b. (a -> b) -> a -> b
$ (IRCRWState -> Bool) -> LB Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (String -> Map String Bool -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member String
"offlinerc" (Map String Bool -> Bool)
-> (IRCRWState -> Map String Bool) -> IRCRWState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRCRWState -> Map String Bool
ircPersists)
            when continue replLoop

lockRC :: OfflineRC ()
lockRC :: ModuleT OfflineRCState LB ()
lockRC = do
    (LBState (ModuleT OfflineRCState LB)
 -> (LBState (ModuleT OfflineRCState LB)
     -> ModuleT OfflineRCState LB ())
 -> ModuleT OfflineRCState LB ())
-> ModuleT OfflineRCState LB ()
forall a.
(LBState (ModuleT OfflineRCState LB)
 -> (LBState (ModuleT OfflineRCState LB)
     -> ModuleT OfflineRCState LB ())
 -> ModuleT OfflineRCState LB a)
-> ModuleT OfflineRCState LB a
forall (m :: * -> *) a.
MonadLBState m =>
(LBState m -> (LBState m -> m ()) -> m a) -> m a
withMS ((LBState (ModuleT OfflineRCState LB)
  -> (LBState (ModuleT OfflineRCState LB)
      -> ModuleT OfflineRCState LB ())
  -> ModuleT OfflineRCState LB ())
 -> ModuleT OfflineRCState LB ())
-> (LBState (ModuleT OfflineRCState LB)
    -> (LBState (ModuleT OfflineRCState LB)
        -> ModuleT OfflineRCState LB ())
    -> ModuleT OfflineRCState LB ())
-> ModuleT OfflineRCState LB ()
forall a b. (a -> b) -> a -> b
$ \ LBState (ModuleT OfflineRCState LB)
cur LBState (ModuleT OfflineRCState LB) -> ModuleT OfflineRCState LB ()
writ -> do
        Bool
-> ModuleT OfflineRCState LB () -> ModuleT OfflineRCState LB ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OfflineRCState
LBState (ModuleT OfflineRCState LB)
cur OfflineRCState -> OfflineRCState -> Bool
forall a. Eq a => a -> a -> Bool
== OfflineRCState
0) (ModuleT OfflineRCState LB () -> ModuleT OfflineRCState LB ())
-> ModuleT OfflineRCState LB () -> ModuleT OfflineRCState LB ()
forall a b. (a -> b) -> a -> b
$ do
            String
-> (IrcMessage -> ModuleT OfflineRCState LB ())
-> ModuleT OfflineRCState LB ()
forall st. String -> Server st -> ModuleT st LB ()
registerServer String
"offlinerc" IrcMessage -> ModuleT OfflineRCState LB ()
handleMsg
            LB () -> ModuleT OfflineRCState LB ()
forall (m :: * -> *) a.
Monad m =>
m a -> ModuleT OfflineRCState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LB () -> ModuleT OfflineRCState LB ())
-> LB () -> ModuleT OfflineRCState LB ()
forall a b. (a -> b) -> a -> b
$ (IRCRWState -> IRCRWState) -> LB ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRCRWState -> IRCRWState) -> LB ())
-> (IRCRWState -> IRCRWState) -> LB ()
forall a b. (a -> b) -> a -> b
$ \IRCRWState
state' ->
                IRCRWState
state' { ircPersists = M.insert "offlinerc" True $ ircPersists state' }
        LBState (ModuleT OfflineRCState LB) -> ModuleT OfflineRCState LB ()
writ (OfflineRCState
LBState (ModuleT OfflineRCState LB)
cur OfflineRCState -> OfflineRCState -> OfflineRCState
forall a. Num a => a -> a -> a
+ OfflineRCState
1)

unlockRC :: OfflineRC ()
unlockRC :: ModuleT OfflineRCState LB ()
unlockRC = (LBState (ModuleT OfflineRCState LB)
 -> (LBState (ModuleT OfflineRCState LB)
     -> ModuleT OfflineRCState LB ())
 -> ModuleT OfflineRCState LB ())
-> ModuleT OfflineRCState LB ()
forall a.
(LBState (ModuleT OfflineRCState LB)
 -> (LBState (ModuleT OfflineRCState LB)
     -> ModuleT OfflineRCState LB ())
 -> ModuleT OfflineRCState LB a)
-> ModuleT OfflineRCState LB a
forall (m :: * -> *) a.
MonadLBState m =>
(LBState m -> (LBState m -> m ()) -> m a) -> m a
withMS ((LBState (ModuleT OfflineRCState LB)
  -> (LBState (ModuleT OfflineRCState LB)
      -> ModuleT OfflineRCState LB ())
  -> ModuleT OfflineRCState LB ())
 -> ModuleT OfflineRCState LB ())
-> (LBState (ModuleT OfflineRCState LB)
    -> (LBState (ModuleT OfflineRCState LB)
        -> ModuleT OfflineRCState LB ())
    -> ModuleT OfflineRCState LB ())
-> ModuleT OfflineRCState LB ()
forall a b. (a -> b) -> a -> b
$ \ LBState (ModuleT OfflineRCState LB)
cur LBState (ModuleT OfflineRCState LB) -> ModuleT OfflineRCState LB ()
writ -> do
    Bool
-> ModuleT OfflineRCState LB () -> ModuleT OfflineRCState LB ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OfflineRCState
LBState (ModuleT OfflineRCState LB)
cur OfflineRCState -> OfflineRCState -> Bool
forall a. Eq a => a -> a -> Bool
== OfflineRCState
1) (ModuleT OfflineRCState LB () -> ModuleT OfflineRCState LB ())
-> ModuleT OfflineRCState LB () -> ModuleT OfflineRCState LB ()
forall a b. (a -> b) -> a -> b
$ String -> ModuleT OfflineRCState LB ()
forall mod. String -> ModuleT mod LB ()
unregisterServer String
"offlinerc"
    LBState (ModuleT OfflineRCState LB) -> ModuleT OfflineRCState LB ()
writ (OfflineRCState
LBState (ModuleT OfflineRCState LB)
cur OfflineRCState -> OfflineRCState -> OfflineRCState
forall a. Num a => a -> a -> a
- OfflineRCState
1)