module Plugins
( Plugin
, pluginPrefix
, pluginName
, pluginSummary
, pluginProc
, Plugins
, findPlugins
, listPlugins
, lookupPlugin
, callPlugin
, PluginException (..)
) where
import Control.Applicative
import Control.Exception (Exception)
import Control.Monad
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict (StateT, get, put)
import Data.Conduit
import Data.Hashable (Hashable)
import Data.HashSet (HashSet)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Conduit.List as CL
import Data.Conduit.Lift (evalStateC)
import qualified Data.List as L
import Data.List.Split (splitOn)
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Data.Monoid
import System.Directory
import System.Process (CreateProcess, proc, readProcess, readProcessWithExitCode, createProcess, waitForProcess)
import System.FilePath ((</>), getSearchPath, splitExtension)
import System.Environment (getEnv)
import System.Exit (ExitCode (..))
data Plugin = Plugin
{ _pluginPrefix :: !Text
, _pluginName :: !Text
, _pluginSummary :: !Text
}
deriving (Show)
pluginPrefix :: Plugin -> Text
pluginPrefix = _pluginPrefix
pluginName :: Plugin -> Text
pluginName = _pluginName
pluginSummary :: Plugin -> Text
pluginSummary = _pluginSummary
pluginProc :: Plugin -> [String] -> CreateProcess
pluginProc = proc . pluginProcessName
pluginProcessName :: Plugin -> String
pluginProcessName p = unpack $ pluginPrefix p <> "-" <> pluginName p
data Plugins = Plugins
{ _pluginsPrefix :: !Text
, _pluginsMap :: !(HashMap Text Plugin)
}
deriving (Show)
findPlugins :: Text -> IO Plugins
findPlugins t = fmap (Plugins t)
$ discoverPlugins t
$$ awaitForever (toPlugin t)
=$ CL.fold insertPlugin HashMap.empty
where
insertPlugin m p = HashMap.insert (pluginName p) p m
toPlugin :: (MonadIO m) => Text -> Text -> Producer m Plugin
toPlugin prefix name = do
let proc = unpack $ prefix <> "-" <> name
(exit, out, _err) <- liftIO $ readProcessWithExitCode proc ["--summary"] ""
case exit of
ExitSuccess -> case T.lines (pack out) of
[summary] -> yield $ Plugin
{ _pluginPrefix = prefix
, _pluginName = name
, _pluginSummary = summary
}
_ -> return ()
_ -> return ()
data PluginException
= PluginNotFound !Plugins !Text
| PluginExitFailure !Plugin !Int
deriving (Show, Typeable)
instance Exception PluginException
lookupPlugin :: Plugins -> Text -> Maybe Plugin
lookupPlugin ps t = HashMap.lookup t $ _pluginsMap ps
listPlugins :: Plugins -> [Plugin]
listPlugins = HashMap.elems . _pluginsMap
callPlugin :: (MonadIO m, MonadThrow m)
=> Plugins -> Text -> [String] -> m ()
callPlugin ps name args = case lookupPlugin ps name of
Nothing -> throwM $ PluginNotFound ps name
Just plugin -> do
exit <- liftIO $ do
(_, _, _, process) <- createProcess $ pluginProc plugin args
waitForProcess process
case exit of
ExitFailure i -> throwM $ PluginExitFailure plugin i
ExitSuccess -> return ()
discoverPlugins :: MonadIO m => Text -> Producer m Text
discoverPlugins t
= getPathDirs
$= clNub
$= awaitForever (executablesPrefixed $ unpack $ t <> "-")
$= CL.map pack
$= clNub
executablesPrefixed :: (MonadIO m) => FilePath -> FilePath -> Producer m FilePath
executablesPrefixed prefix dir
= pathToContents dir
$= CL.filter (L.isPrefixOf prefix)
$= clFilterM (fileExistsIn dir)
$= clFilterM (isExecutableIn dir)
$= CL.mapMaybe (L.stripPrefix prefix . dropExeExt)
dropExeExt :: FilePath -> FilePath
dropExeExt fp
| y == ".exe" = x
| otherwise = fp
where
(x, y) = splitExtension fp
getPathDirs :: (MonadIO m) => Producer m FilePath
getPathDirs = liftIO getSearchPath >>= mapM_ yield
pathToContents :: (MonadIO m) => FilePath -> Producer m FilePath
pathToContents dir = do
exists <- liftIO $ doesDirectoryExist dir
when exists $ do
contents <- liftIO $ getDirectoryContents dir
CL.sourceList contents
fileExistsIn :: (MonadIO m) => FilePath -> FilePath -> m Bool
fileExistsIn dir file = liftIO $ doesFileExist $ dir </> file
isExecutableIn :: (MonadIO m) => FilePath -> FilePath -> m Bool
isExecutableIn dir file = liftIO $ do
perms <- getPermissions $ dir </> file
return (executable perms)
clFilterM :: Monad m => (a -> m Bool) -> Conduit a m a
clFilterM pred = awaitForever $ \a -> do
predPassed <- lift $ pred a
when predPassed $ yield a
clNub :: (Monad m, Eq a, Hashable a)
=> Conduit a m a
clNub = evalStateC HashSet.empty clNubState
clNubState :: (Monad m, Eq a, Hashable a)
=> Conduit a (StateT (HashSet a) m) a
clNubState = awaitForever $ \a -> do
seen <- lift get
unless (HashSet.member a seen) $ do
lift $ put $ HashSet.insert a seen
yield a