Reaktor.Plugins.System: print exec errors to IRCv0.1.1

2 files changed, 174 insertions, 168 deletions

diff --git a/src/Reaktor/Plugins/System.hs b/src/Reaktor/Plugins/System.hs
index 88b8d84..8154423 100644
--- a/src/Reaktor/Plugins/System.hs
+++ b/src/Reaktor/Plugins/System.hs
@@ -5,23 +5,25 @@
 {-# LANGUAGE RecordWildCards #-}
 module Reaktor.Plugins.System (new) where
 
---import Prelude.Extended
 import Blessings
 import Control.Applicative
 import Control.Concurrent (forkIO)
-import Control.Exception (finally)
---import Data.Aeson
-import Data.ByteString.Char8.Extended (ByteString)
+import Control.Exception
 import qualified Data.ByteString.Char8.Extended as BS
-import qualified Data.Map as M
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Search as BS
+import qualified Data.HashMap.Lazy as M
+import qualified Data.List as L
+import qualified Data.Vector as V
+import Prelude.Extended
 import Reaktor
+import Reaktor.Plugins.System.Internal
 import System.Environment (getEnvironment)
+import System.Exit
 import System.FilePath.Posix (takeBaseName)
 import System.IO (BufferMode(LineBuffering),hSetBuffering)
 import System.IO (Handle,hClose,hPutStr,hIsEOF)
-import Reaktor.Plugins.System.Internal -- TODO rename to Reaktor.Plugins.System again
-import System.Process (StdStream(CreatePipe),waitForProcess)
-import System.Process (createProcess,CreateProcess(..),proc)
+import System.Process
 import qualified Text.Regex.PCRE.Heavy as RE
 import qualified Text.Regex.PCRE.Light as RE
 
@@ -29,28 +31,27 @@ import qualified Text.Regex.PCRE.Light as RE
 new :: Config -> Actions -> IO (Message -> IO ())
 new config@Config{..} actions@Actions{..} = do
     pure $ \case
-        Message (Just prefix) "PRIVMSG" (msgtarget:text:[]) -> do
-
-          nick_ <- aGetNick
-          let hs = maybe [] id (M.lookup "PRIVMSG" cHooks)
-          mapM_ (\h -> run1 config actions nick_ h prefix msgtarget text) hs
+        Message (Just prefix) cmd (msgtarget:text:[]) | elem cmd ["PRIVMSG", "JOIN"] -> do
+          let hooks = maybe [] id (M.lookup cmd cHooks)
+          mapM_ (\h -> run1 config actions h prefix msgtarget text) hooks
 
         Message (Just prefix) "JOIN" (channel:[]) -> do
-          nick_ <- aGetNick
-          let hs = maybe [] id (M.lookup "JOIN" cHooks)
-          mapM_ (\h -> run1 config actions nick_ h prefix channel "") hs
+          let hooks = maybe [] id (M.lookup "JOIN" cHooks)
+          mapM_ (\h -> run1 config actions h prefix channel "") hooks
 
         _ -> pure ()
 
 
-run1 :: Config -> Actions -> ByteString -> SystemParams -> ByteString -> ByteString -> ByteString -> IO ()
-run1 config@Config{..} actions@Actions{..} nick_ params prefix msgtarget text = do
+run1 :: Config -> Actions -> Hook -> ByteString -> ByteString -> ByteString -> IO ()
+run1 Config{..} Actions{..} Hook{..} prefix msgtarget text = do
+    nick <- aGetNick
+
     let
         isActivated =
-          case activate params of
+          case hActivate of
             Always -> Just ""
             Match ->
-              case pattern params of
+              case hPattern of
                 Nothing -> Nothing
                 Just pat ->
                   let
@@ -62,8 +63,8 @@ run1 config@Config{..} actions@Actions{..} nick_ params prefix msgtarget text =
                       else Just ""
             Query ->
               if
-                | BS.isPrefixOf (nick_ <> ":") text ->
-                  Just (nick_ <> ":")
+                | BS.isPrefixOf (nick <> ":") text ->
+                  Just (nick <> ":")
                 | BS.isPrefixOf "*:" text ->
                   Just "*:"
                 | isQuery ->
@@ -72,17 +73,16 @@ run1 config@Config{..} actions@Actions{..} nick_ params prefix msgtarget text =
                   Nothing
 
         audience = if isQuery then from else msgtarget
+        from = BS.takeWhile (/='!') prefix
 
         -- TODO check if msgtarget is one of our channels?
         --      what if our nick has changed?
-        isQuery = msgtarget == nick_
-
-        from = BS.takeWhile (/='!') prefix
-          --maybe prefix (flip BS.take prefix) $ BS.findIndex (=='!') prefix
+        isQuery = msgtarget == nick
 
     case isActivated of
       Just trigger -> do
-        let cmdline = BS.dropWhile (==' ') $ BS.drop (BS.length trigger) text
+        let
+            cmdline = BS.dropWhile (==' ') $ BS.drop (BS.length trigger) text
             resultPrefix = if isQuery then [] else [from <> ":"]
 
             parseCommandLine' pat s =
@@ -91,106 +91,109 @@ run1 config@Config{..} actions@Actions{..} nick_ params prefix msgtarget text =
                 result = RE.scan patternRE s
                 patternRE = RE.compile pat []
 
-            parse' =
-              case pattern params of
-                Nothing -> [] -- TODO everything
-                Just pat -> parseCommandLine' pat cmdline
-
-            headMaybe x = if null x then Nothing else Just (head x)
-
-            -- TODO rename "command" to something like "commandSpec"
-            command' = case command params of
-              Capture i ->
-                case headMaybe (drop (fromIntegral i - 1) parse') of
-                  Nothing -> Nothing
-                  Just k -> M.lookup k (commands params)
-
-              CaptureOr c -> Just c
-
-            cmdName = case command params of
-              Capture i ->
-                case headMaybe (drop (fromIntegral i - 1) parse') of
-                  Nothing -> "<CMDERP>"
-                  Just k -> k
-
-              CaptureOr c -> BS.pack (takeBaseName $ commandPath c)
-
-            args' =
-                map BS.unpack $
-                map (maybe "" id) $
-                reverse $
-                dropWhile (==Nothing) $
-                reverse $
-                map f (arguments params)
-              where
-                f arg = case arg of
-                  Capture i ->
-                    case headMaybe (drop (fromIntegral i - 1) parse') of
-                      Nothing -> Nothing
-                      Just k -> Just k
-
-                  CaptureOr x -> Just x
-
-        case command' of
-          Just c -> do
-            -- aSend <- gets s_sendMsg
-            -- putLog_ <- gets s_putLog
-            let onErrLine s =
-                  aLog $ SGR [31,1] $
-                    Plain (BS.pack (takeBaseName $ commandPath c) <> ": "<> s)
-
-                onOutLine s =
-                  aSend (privmsg audience [s])
-
-                extraEnv = [("_prefix", BS.unpack prefix),
-                            ("_from", BS.unpack from)]
-
-            fork config actions c args' (Just extraEnv) "" onOutLine onErrLine
+            captures =
+              V.fromList $
+                case hPattern of
+                  Nothing -> [] -- TODO everything?
+                  Just pat -> parseCommandLine' pat cmdline
+
+            capture i = captures V.!? (i - 1)
+
+            name =
+              case hCommand of
+                Capture i -> fromMaybe "<unnamed>" (capture i)
+                CaptureOr Command{..} -> BS.pack $ takeBaseName $ commandPath
+
+            command =
+              case hCommand of
+                Capture i -> (`M.lookup` hCommands) =<< capture i
+                CaptureOr c -> Just c
+
+            args =
+              map (maybe "" BS.unpack)
+                $ L.dropWhileEnd isNothing
+                -- $ map getArgument hArguments
+                $ flip map hArguments
+                $ \case
+                  Capture i -> capture i
+                  CaptureOr s -> Just s
+
+        case command of
+          Just Command{..} -> do
+            baseEnv <- getEnvironment
+
+            let
+                onExit code = do
+                  let s = BS.show code
+                      (sig, col) =
+                        if code == ExitSuccess
+                          then (SGR [38,5,235] "* ", SGR [38,5,107])
+                          else (SGR [38,5,235] "! ", SGR [31,1])
+                  aLog $ sig <> col (Plain $ name <> ": " <> s)
+
+                onExcept :: SomeException -> IO ()
+                onExcept e = do
+                  let s0 = BS.show e
+                      s = BL.toStrict $ BS.replace (BS.pack commandPath) name s0
+                  aLog $ SGR [38,5,235] "! "
+                      <> SGR [31,1] (Plain $ name <> ": " <> s0)
+                  aSend (privmsg audience (resultPrefix <> [s]))
+
+                -- TODO use differenct colors
+                onErrLine s = aSend (privmsg audience [s])
+                onOutLine s = aSend (privmsg audience [s])
+
+                extraEnv =
+                    [ ("_prefix", BS.unpack prefix)
+                    , ("_from", BS.unpack from)
+                    ]
+
+                env =
+                  M.toList $ mconcat
+                    [ M.fromList extraEnv
+                    , maybe mempty id commandEnv
+                    , M.fromList baseEnv
+                    ]
+
+                cwd = commandWorkDir <|> hWorkDir <|> cWorkDir
+
+            fork commandPath args cwd (Just env) "" onOutLine onErrLine onExit
+              `catch` onExcept
 
           Nothing -> do
-            aSend (privmsg audience (resultPrefix <> [cmdName <> ": command not found"]))
+            let s = name <> ": command not found"
+            aSend (privmsg audience (resultPrefix <> [s]))
 
       Nothing -> return ()
 
-fork :: Config
-     -> Actions
-     -> SystemCommand
+fork :: FilePath
      -> [String]
+     -> Maybe FilePath
      -> Maybe [(String, String)]
      -> String
      -> (ByteString -> IO ())
      -> (ByteString -> IO ())
+     -> (ExitCode -> IO ())
      -> IO ()
-fork Config{..} Actions{..} cmd args extraEnv input onOutLine onErrLine = do
-
-    baseEnv <- getEnvironment
-
-    let procEnv = M.toList $ mconcat [
-                    maybe mempty M.fromList extraEnv,
-                    maybe mempty id (commandEnv cmd),
-                    M.fromList baseEnv
-                  ]
-
-    (inh, outh, errh) <- do
-      (Just inh, Just outh, Just errh, ph) <-
-        createProcess (proc (commandPath cmd) args) {
-          cwd = commandWorkDir cmd <|> cDefaultWorkDir,
-          env = Just procEnv,
-          std_in = CreatePipe,
-          std_out = CreatePipe,
-          std_err = CreatePipe,
-          close_fds = True,
-          create_group = True,
-          new_session = True
-        }
-      _ <- forkIO $ waitForProcess ph >> return ()
-      return (inh, outh, errh)
-
-    mapM_ forkIO [
-        hPutStr inh input `finally` hClose inh,
-        hWithLines outh onOutLine,
-        hWithLines errh onErrLine
-      ]
+fork path args cwd env input onOutLine onErrLine onExit = do
+    let
+        p = (proc path args)
+              { cwd = cwd
+              , env = env
+              , std_in = CreatePipe
+              , std_out = CreatePipe
+              , std_err = CreatePipe
+              , close_fds = True
+              , create_group = True
+              , new_session = True
+              }
+    withCreateProcess p $ \(Just inh) (Just outh) (Just errh) ph -> do
+      mapM_ forkIO [
+          hPutStr inh input `finally` hClose inh,
+          hWithLines outh onOutLine,
+          hWithLines errh onErrLine
+        ]
+      waitForProcess ph >>= onExit
 
 
 hWithLines :: Handle -> (ByteString -> IO ()) -> IO ()
diff --git a/src/Reaktor/Plugins/System/Internal.hs b/src/Reaktor/Plugins/System/Internal.hs
index 2ed923d..ac707ae 100644
--- a/src/Reaktor/Plugins/System/Internal.hs
+++ b/src/Reaktor/Plugins/System/Internal.hs
@@ -1,15 +1,15 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Reaktor.Plugins.System.Internal where
 
 import Prelude.Extended
 import Data.Aeson
-import qualified Data.ByteString.Char8.Extended as BS
-import qualified Data.Map as M
 import Reaktor ()
 
 
+
 -- TODO this needs better names :)
-data CaptureOr a = Capture Integer | CaptureOr a
+data CaptureOr a = Capture Int | CaptureOr a
   deriving Show -- TODO killme
 
 instance FromJSON a => FromJSON (CaptureOr a) where
@@ -20,60 +20,63 @@ instance FromJSON a => FromJSON (CaptureOr a) where
 data Activate = Always | Match | Query
 
 instance FromJSON Activate where
-  parseJSON (String "always") = pure Always
-  parseJSON (String "match") = pure Match
-  parseJSON (String "query") = pure Query
-  parseJSON _ = undefined
+  parseJSON = \case
+      String "always" -> pure Always
+      String "match" -> pure Match
+      String "query" -> pure Query
+      _ -> undefined
 
-data Config = Config {
-  cDefaultWorkDir :: Maybe FilePath,
-  -- TODO IrcCommand as key for map
-  cHooks :: M.Map BS.ByteString [SystemParams]
-}
+data Config = Config
+    { cWorkDir :: Maybe FilePath
+    , cHooks :: HashMap ByteString [Hook]
+    }
 
 instance Default Config where
   def = Config Nothing mempty
 
 instance FromJSON Config where
-  parseJSON (Object v) =
-    Config
-      <$> v .:? "workdir"
-      <*> v .:? "hooks" .!= M.empty
-  parseJSON _ = pure undefined
-
-data SystemParams = SystemParams {
-  activate :: Activate,
-  pattern :: Maybe BS.ByteString, -- TODO RE
-  command :: CaptureOr SystemCommand,
-  arguments :: [CaptureOr BS.ByteString],
-  workDir :: Maybe FilePath,
-  commands :: M.Map BS.ByteString SystemCommand
-}
-
-instance FromJSON SystemParams where
-  parseJSON (Object v) =
-      SystemParams
-        <$> v .:? "activate" .!= Query
-        <*> v .:? "pattern"
-        <*> v .: "command"
-        <*> v .:? "arguments" .!= []
-        <*> v .:? "workdir"
-        <*> v .:? "commands" .!= M.empty
-  parseJSON _ = pure undefined
-
-
-data SystemCommand = SystemCommand {
-    commandPath :: FilePath,
-    commandWorkDir :: Maybe FilePath,
-    commandEnv :: Maybe (M.Map String String)
-  }
-  deriving Show -- TODO killme
+  parseJSON = \case
+      Object v ->
+        Config
+          <$> v .:? "workdir"
+          <*> v .:? "hooks" .!= mempty
+      _ -> undefined
+
+data Hook = Hook
+    { hActivate :: Activate
+    , hPattern :: Maybe ByteString
+    , hCommand :: CaptureOr Command
+    , hArguments :: [CaptureOr ByteString]
+    , hWorkDir :: Maybe FilePath
+    , hCommands :: HashMap ByteString Command
+    }
+
+instance FromJSON Hook where
+  parseJSON = \case
+      Object v ->
+        Hook
+          <$> v .:? "activate" .!= Query
+          <*> v .:? "pattern"
+          <*> v .: "command"
+          <*> v .:? "arguments" .!= []
+          <*> v .:? "workdir"
+          <*> v .:? "commands" .!= mempty
+      _ -> undefined
+
+
+data Command = Command
+    { commandPath :: FilePath
+    , commandWorkDir :: Maybe FilePath
+    , commandEnv :: Maybe (HashMap String String)
+    }
+  deriving Show
 
-instance FromJSON SystemCommand where
-  parseJSON (Object v) =
-      SystemCommand
-        <$> v .: "filename"
-        <*> v .:? "workdir"
-        <*> v .:? "env"
-  parseJSON _ = pure undefined
+instance FromJSON Command where
+  parseJSON = \case
+      Object v ->
+        Command
+          <$> v .: "filename"
+          <*> v .:? "workdir"
+          <*> v .:? "env"
+      _ -> undefined