-----------------------------------------------------------------------------
--
-- Module : Base.Config
-- Copyright : Juergen Nicklisch-Franken
-- License : LGPL
--
-- Maintainer : maintainer@leksah.org
-- Stability : provisional
-- Portability : portabel
--
-- | Plugin Configurations
--
-----------------------------------------------------------------------------
module Base.Config (
loadPluginDescr,
loadPluginDescription,
writePluginDescr,
loadPluginConfig,
writePluginConfig,
loadListFromConfig,
allKnownPlugins,
getPrereqChoices,
defaultConfig,
defaultPlugin
) where
import Base.PluginTypes
import Base.ConfigFile
import Base.Event
import Base.State
import qualified Text.PrettyPrint as PP (text)
import Control.Monad (foldM, filterM, unless)
import Data.Version (showVersion, parseVersion, Version(..))
import Data.List (nubBy, intersperse, isPrefixOf)
import System.Directory (doesFileExist, getDirectoryContents)
import System.FilePath
(dropFileName, (</>), dropExtension, takeExtension, takeFileName)
import Text.ParserCombinators.ReadP (readP_to_S)
import Data.Maybe (mapMaybe)
import qualified Data.Map as Map
(elems, toList, lookup, member, insert, empty)
import Data.Map (Map)
import Base.Graph (topSortGraph)
import Base.State (StateM)
import Control.Monad.IO.Class (MonadIO(..))
-- | Plugin file (.lksp)
defaultPlugin = Plugin {
plName = "",
plVersion = Version[][],
plModule = "",
plInterface = "",
plPrerequisites = [],
plChoices = [],
plSynopsis = ""}
pluginDescr :: [FieldDescriptionS Plugin]
pluginDescr = [
mkFieldS
"Name of the plugin"
Nothing
stringPrinter
stringParser
plName
(\ b a -> a{plName = b})
, mkFieldS
"Version"
Nothing
(stringPrinter . showVersion)
versionParser
plVersion
(\ b a -> a{plVersion = b})
, mkFieldS
"Module"
Nothing
stringPrinter
stringParser
plModule
(\ b a -> a{plModule = b})
, mkFieldS
"Interface"
Nothing
stringPrinter
stringParser
plInterface
(\ b a -> a{plInterface = b})
, mkFieldS
"Prerequisite list"
Nothing
(stringPrinter . showPluginList)
parsePluginList
plPrerequisites
(\ b a -> a{plPrerequisites = b})
, mkFieldS
"Synopsis"
(Just "or call it comment")
stringPrinter
stringParser
plSynopsis
(\ b a -> a{plSynopsis = b})
]
loadPluginDescr :: FilePath -> IO Plugin
loadPluginDescr fn = readFieldsSimple fn pluginDescr defaultPlugin
writePluginDescr :: FilePath -> Plugin -> IO ()
writePluginDescr fpath descr = do
exists <- doesFileExist fpath
if exists
then do
descrOld <- loadPluginDescr fpath
unless (descrOld == descr) $
writeFile fpath (showFieldsSimple descr pluginDescr)
else writeFile fpath (showFieldsSimple descr pluginDescr)
-- | Plugin configfile (.lkshc)
defaultConfig = PluginConfig {
cfName = "Unnamed zombie",
cfVersion = Version[0][],
cfPlugins = [],
cfChoices = [],
cfSynopsis = ""}
pluginConf :: [FieldDescriptionS PluginConfig]
pluginConf = [
mkFieldS
"Name of the config"
Nothing
stringPrinter
stringParser
cfName
(\ b a -> a{cfName = b})
, mkFieldS
"Version"
Nothing
(stringPrinter . showVersion)
versionParser
cfVersion
(\ b a -> a{cfVersion = b})
, mkFieldS
"Plugin list"
Nothing
(stringPrinter . showPluginList)
parsePluginList
cfPlugins
(\ b a -> a{cfPlugins = b})
, mkFieldS
"Synopsis"
(Just "or call it comment")
stringPrinter
stringParser
cfSynopsis
(\ b a -> a{cfSynopsis = b})
]
loadPluginConfig :: FilePath -> IO PluginConfig
loadPluginConfig fn = readFieldsSimple fn pluginConf defaultConfig
writePluginConfig :: FilePath -> PluginConfig -> IO ()
writePluginConfig fpath config = do
configOld <- loadPluginConfig fpath
unless (configOld == config) $
writeFile fpath (showFieldsSimple config pluginConf)
type Error = String
loadPluginDescription :: FilePath -> (PluginName, VersionBounds) -> IO (Either Plugin Error)
loadPluginDescription fp (name,bounds) = do
versions <- getPluginVersions fp name
case selectOptimalVersion versions bounds of
Nothing -> return (Right ("Can't select version for plugin: " ++ name))
Just v -> getPluginDescr fp name v >>= \ p -> return (Left p)
-- | Returns the description of a plugin
getPluginDescr :: FilePath -> String -> Version -> IO Plugin
getPluginDescr fp name version = loadPluginDescr
(fp </> name ++ "-" ++ showVersion version ++ ".lkshp")
-- | Take the latest allowed
selectOptimalVersion :: [Version] -> VersionBounds -> Maybe Version
selectOptimalVersion [] _ = Nothing
selectOptimalVersion versions (Nothing,Nothing) = Just $ maximum versions
selectOptimalVersion versions (Just vl,Nothing) = case [ v | v <- versions, v >= vl] of
[] -> Nothing
l -> Just $ maximum l
selectOptimalVersion versions (Nothing,Just vu) = case [ v | v <- versions, v <= vu] of
[] -> Nothing
l -> Just $ maximum l
selectOptimalVersion versions (Just vl,Just vu) = case [ v | v <- versions, v >= vl && v <= vu] of
[] -> Nothing
l -> Just $ maximum l
-- | Returns a list of versions
getPluginVersions :: FilePath -> String -> IO [Version]
getPluginVersions fp name = catch (do
filesAndDirs <- getDirectoryContents fp
files <- filterM (\f -> doesFileExist (fp </> f)) filesAndDirs
let relevantFiles = [ nameWithVersion | nameWithVersion <- files,
isPrefixOf name nameWithVersion,
takeExtension nameWithVersion == ".lkshp"]
return (mapMaybe (\ f ->
case filter (\r -> snd r == "") ((readP_to_S parseVersion) (extractVersion f)) of
(a,_):_ -> Just a
[] -> Nothing) relevantFiles))
(\e -> do
-- putStrLn "Config>>getPluginVersions: ++ show e"
return [])
where
extractVersion string = drop (length name + 1) (dropExtension string)
-- | First collect all Plugins, then make them a graph and topsort it
loadListFromConfig :: BaseEvent -> FilePath -> PluginConfig -> StateM [Plugin]
loadListFromConfig baseEvent fp PluginConfig{cfPlugins = prerequ} = do
collectedPlugins <- foldM loadDeep Map.empty prerequ
let pluginGraph = foldr (buildGraph collectedPlugins) Map.empty (Map.elems collectedPlugins)
return (reverse (topSortGraph pluginGraph))
where
loadDeep :: Map String Plugin -> Prerequisite -> StateM (Map String Plugin)
loadDeep map prerequ@(name,version) | Map.member name map = return map
| otherwise = do
res <- liftIO $ loadPluginDescription fp prerequ
case res of
Left plugin -> do
let map2 = Map.insert name plugin map
foldM loadDeep map2 (plPrerequisites plugin)
Right error -> do
message Error ("Can't load plugin descr " ++ show prerequ ++ " " ++ error)
return map
buildGraph allPlugs plug graph =
Map.insert plug
(mapMaybe (\ (name,_) -> Map.lookup name allPlugs) (plPrerequisites plug)) graph
allKnownPlugins :: FilePath -> IO [Plugin]
allKnownPlugins fp = do
filesAndDirs <- getDirectoryContents fp
files <- filterM (\f -> doesFileExist (fp </> f)) filesAndDirs
let relevantFiles = [ fp | fp <- files, takeExtension fp == ".lkshp"]
mapM (\ fp -> loadPluginDescr fp) relevantFiles
getPrereqChoices :: FilePath -> IO [Prerequisite]
getPrereqChoices currentConfigPath= do
possiblePlugins <- allKnownPlugins (dropFileName currentConfigPath)
let possibleBounds = map getStandardBounds possiblePlugins
let possibleChoices = nubBy (\e1 e2 -> fst e1 == fst e2) $
[ e | e@(n,_) <- possibleBounds]
return possibleChoices
getStandardBounds :: Plugin -> Prerequisite
getStandardBounds Plugin{plName = name, plVersion = version} =
(name,(Just version,Just (nextVersion version)))
where
nextVersion (Version (a:b:_) []) = Version [a,b+1] []
nextVersion (Version [a] []) = Version [a,1] []
nextVersion (Version [] []) = Version [1,1] []