-- |The 'Config' module implements both command line and configuration
-- file option handling.  It converts the command line parameters into
-- Flag objects, and then expands any Include, Use, or Config flags.
-- Every command line parameter has an equivalent format that can
-- appear in the configuration file.  Using Debian conventions, a
-- command line option such as
--
--    --some-option=value
--
-- could appear in a configuration using this syntax:
--
--    Some-Option: value
--
-- This is the format used in Debian Control files, and is similar to
-- the format described in RFC-922.  Note that a value in a control
-- file can be continued onto multiple lines by prefixing the extra
-- lines with whitespace, as described here:
-- <http://www.debian.org/doc/debian-policy/ch-controlfields.html>
--
-- See the documentation of the Flag datatype below for a description
-- of the features this module supports.
--
-- Author: David Fox <david.fox@linspire.com>
module Linspire.Debian.Config
    (Flag(Use, Name, Include, Param),
     computeConfig, -- String -> [OptDescr Flag] -> Maybe String -> IO [[Flag]]
     findParams,    -- [Flag] -> String -> [String]
     findParam,	    -- [Flag] -> String -> Maybe String
     findBool)	    -- [Flag] -> String -> Bool
    where

import Control.Exception
import Control.Monad
import Data.Char(isDigit)
import Data.List
import Data.Maybe
import System.Directory
import System.Environment as Environment
import System.Console.GetOpt
import Text.Regex
import Linspire.Debian.Control

-- |The command line arguments are converted to a list of 'Flag'
-- objects, and this list is then expanded by the 'computeConfig'
-- function and the result (due to the operation of 'Use') is a list
-- of Flag lists.
data Flag
    = Include FilePath |
      -- ^ Any --include or --config flag is converted to an Include
      -- object, where the value is a filename containing
      -- configuration information.  If no --config option is given,
      -- default locations will be used as described in the
      -- 'computeConfig' function.
      Name String |
      -- ^ This option has no command line equivalent, it is used to
      -- assign a name to a paragraph which can be referred to by a
      -- Use flag.
      Use [String] |
      -- ^ The --use flag is used to refer to one or more named paragraphs.
      -- Referring to a single named paragraph causes the parameters in that
      -- paragraph to be added to the set of parameters we are computing.
      -- If several paragraphs are named, a copy the current set of parameters
      -- is created for each named paragraph, and the result is several sets
      -- of parameters.  This is what causes the result of the computeConfig
      -- function to be a list of Flag lists.
      Param String String
      -- ^ Any other named parameter (No command line equivalent)
      deriving Eq

-- |Display a flag in (pseudo) RFC-922 format.
instance Show Flag where
    show (Include x) = "Include: " ++ x
    show (Name x) = "Name: " ++ x
    show (Use xs) = "Use: " ++ consperse " " xs
    show (Param name value) = name ++ ": " ++ value

instance Read Flag where
    readsPrec _ =
        let re = mkRegex "^([^ \t:]+):([^\n]*(\n[ \t].*)*)($|\n)" in
        (\ s ->
             case matchRegexAll re s of
               Just (_, _, after, [name, value, _, _]) ->
                   case name of
                     "Include" -> [(Include (stripWS value), after)]
                     "Config"  -> [(Include (stripWS value), after)]
                     "Name" -> [(Name (stripWS value), after)]
                     "Use" -> [(Use (words value), after)]
                     _ -> [(Param (stripWS name) (stripWS value), after)]
               _ -> error ("Parse error reading flag: '" ++ s ++ "'"))

-- |Find the configuration file or directory we will use, if any.
-- This is the first that exists among those that are mentioned on the
-- command line, the one in $HOME, and the one in \/etc.
configPath :: String -> [Flag] -> IO [FilePath]
configPath appName flags =
    do
      home <- try (getEnv "HOME") >>=
              return . either
                         (\ _ -> [])
                         (\ path -> [path ++ "/." ++ appName ++ ".d",
                                     path ++ "/." ++ appName ++ ".conf"])
      let etc = ["/etc/" ++ appName ++ ".d", "/etc/" ++ appName ++ ".conf"]
      -- FIXME: If $HOME/.appname is a directory, look inside for config
      -- FIXME: If $HOME/.appname.d exists, read all the files starting with
      -- digits that don't look like backup files.  Same for /etc/appname
      -- and /etc/appname.d.
      let candidates = (findConfigs flags ++ home ++ etc)
      existant <- filterM exists candidates
      return $ maybeToList (listToMaybe existant)
    where
      exists path = do
        fileExists <- doesFileExist path
        dirExists <- doesDirectoryExist path
        return (fileExists || dirExists)

-- |Find the value of the --include and (synonymous) --config flags
findConfigs :: [Flag] -> [FilePath]
findConfigs [] = []
findConfigs (Include path : etc) = path : findConfigs etc
findConfigs (_ : etc) = findConfigs etc

-- |Return the configuration information computed from the command
-- line and the configuration files.  Each list of flags represents a
-- paragraph in the control file, which may be named using the Name:
-- flag and referred to using the Use: flag.
computeConfig :: String -> [OptDescr Flag] -> Maybe String -> IO [[Flag]]
computeConfig appName options global =
    do
      args <- Environment.getArgs
      -- Convert the command line arguments to flags.  Any arguments
      -- not recognized by getOpt is treated as implicit "--use"
      -- parameter.
      commandLineFlags <-
          case getOpt Permute customizedOptions args of
            (o, [], []) -> return o
            (o, extra, []) -> return (o ++ [Use extra])
            (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header customizedOptions))
      -- Compute the configuration file path and then load and expand it.
      configFlags <- configPath appName commandLineFlags >>= tryPaths >>= expandIncludes
      -- Compute the set of global flags.
      let globalFlags =
              case (configFlags, global) of
                -- No configuration info was found
                ([], _) -> []
                -- Use the first section of the configuration file
                (section : _, Nothing) -> section
                -- Use a named section of the configuration file
                (sections, Just name) -> maybe (head sections) id (find (elem (Name name)) sections)
      -- ePut ("configFlags: " ++ show configFlags)
      -- ePut ("commandLineFlags: " ++ show commandLineFlags)
      sequence <- expandSections [commandLineFlags ++ globalFlags] configFlags
      return sequence
    where
      customizedOptions = optSpecs appName options
      header = "Usage: " ++ appName ++ " [OPTION...]"

-- Load a list of configuration files.
tryPaths :: [FilePath] -> IO [[Flag]]
tryPaths paths = do
    -- My.ePut ("tryPaths " ++ show paths ++ "\n")
    flags <- mapM tryPath paths >>= return . mergeControls >>= return . flagsOfControl
    return flags
    where
      -- Each paragraph of the control file becomes a list of flags
      flagsOfControl (Control paragraphs) = map (\ (Paragraph fields) -> (map flagOfField fields)) paragraphs
      flagOfField (Field (name, value)) = read (name ++ ": " ++ value)
      tryPath path =
	  do
            isDir <- doesDirectoryExist path
            case isDir of
              False -> do
                  try (parseControlFromFile path) >>=
                      either (\ _ -> return (Right (Control []))) return >>=
	              either (\ _ -> return (Control [])) return
              True -> do
                   getDirectoryContents path >>=
                      return . map ((path ++ "/") ++) . sort . filter isConfigPart >>=
                      mapM tryPath >>=
                      return . mergeControls
      isConfigPart "" = False
      isConfigPart s | isDigit (head s) && head (reverse s) /= '~' = True
      isConfigPart _ = False
                  

-- Load a list of configuration files.
expandIncludes :: [[Flag]] -> IO [[Flag]]
expandIncludes flags =
    do
      -- ePut ("flags: " ++ show flags)
      let paths = concat (map includePaths flags)
      -- ePut (concat (map (("Include: " ++) . (++ "\n")) paths))
      case paths of
        [] -> return flags
        _ ->
            do
              newflags <- tryPaths paths
              return (flags ++ newflags)
    where
      includePaths (Include path : etc) = path : includePaths etc
      includePaths (_ : etc) = includePaths etc
      includePaths [] = []

-- |Expand occurrences of --use in a list of flag lists.
expandSections :: [[Flag]] -> [[Flag]] -> IO [[Flag]]
expandSections toExpand expansions =
    do
      expanded <- mapM (expandSection [] expansions) toExpand
      return (concat expanded)
    where
      expandSection :: [String] -> [[Flag]] -> [Flag] -> IO [[Flag]]
      expandSection stack expansions toExpand =
          do
            -- ePut ("stack: " ++ show stack)
            -- ePut ("toExpand: " ++ show toExpand)
            -- ePut ("expansions: " ++ show expansions)
            let (useFlags, otherFlags) = partition isUse toExpand
            -- ePut ("useFlags: " ++ show useFlags)
            let sequences = map getNames useFlags
            -- ePut ("sequences: " ++ show sequences)
            -- A sequence of name lists
            let (sequence :: [[String]]) = cartesianProduct sequences
            -- ePut ("sequence: " ++ show sequence)
            -- map (elem stack) (concat sequence)
            let (newstack :: [String]) = nub $ stack ++ concat sequence
            case filter (flip elem $ stack) (concat sequence) of
              [] -> return ()
              l -> error ("Use loop: " ++ show (nub l))
            -- ePut ("newstack: " ++ show newstack)
            -- A sequence of flag lists
            let (sequence' :: [[[Flag]]]) = map (expandNames expansions stack) sequence
            -- ePut ("sequence': " ++ show sequence')
            case sequence' of
              [] ->
                  return [otherFlags]
              _ ->
                  do
                    let sequence'' = map (++ otherFlags) (map concat sequence')
                    -- ePut ("sequence'': " ++ show sequence'')
                    result <- mapM (expandSection newstack expansions) sequence''
                    -- ePut ("result: " ++ show result)
                    return (concat result)

      isUse (Use _) = True
      isUse _ = False
      getNames (Use names) = names
      getNames _ = []

      -- FIXME: use the stack to prevent infinite recursion
      expandNames expansions stack names =
          map (expandName expansions stack) names
      expandName expansions stack name =
          maybe (error ("Section '" ++ name ++ "' not found.")) id (find  (elem (Name name)) expansions)

-- |Command line option specifications.  The caller passes in a list of
-- options, and three additional standard options are added here:
-- --config <path> - specify the path to a configuration file
-- --include <path> - pull in options from a file
-- --use 'name1 name2 ...' - pull in some named sections
optSpecs :: String -> [OptDescr Flag] -> [OptDescr Flag]
optSpecs appName specs =
    specs ++
    [Option ['c'] ["config","include"]	(ReqArg Include "PATH")
     (consperse "\n"
      ["Location of additional configuration files or directories.",
       "This option may be given multiple times, but only the first",
       "one that exists is use.  In addition, if none exist or none",
       "are supplied, four additional paths are tried, in this order:",
       "'/etc/" ++ appName ++ ".d', '/etc/" ++ appName ++ ".conf', '$HOME/." ++ appName ++ ".d',",
       "and '$HOME/." ++ appName ++ ".conf'.  If the configuration path",
       "specifies a directory all the files in the directory that begin",
       "with digits are read in lexical order and merged.  If it is a",
       "regular file, it is read and the result is used."]),
     Option [] ["use"]		(ReqArg (Use . words) "NAME")
     (consperse "\n"
      ["Used to refer to a sequence of named section of the configuration",
       "file.  The parameters defined in the section with the line",
       "'Name: NAME' will be substituted for this argument.  Each of the",
       "elements will be expanded and executed in sequence."])]

-- |Return all values of a string paramter in a flag list.
findParams :: [Flag] -> String -> [String]
findParams (Param name value : etc) sought | name == sought = value : (findParams etc sought)
findParams (_ : etc) sought = findParams etc sought
findParams [] _ = []

-- |Return the value of a string paramter in a flag list.
findParam :: [Flag] -> String -> Maybe String
findParam (Param name value : _) sought | name == sought = Just value
findParam (_ : etc) sought = findParam etc sought
findParam [] _ = Nothing

-- |Return the value of a boolean paramter in a flag list.
findBool :: [Flag] -> String -> Bool
findBool flags sought = maybe False (\ _ -> True) (findParam flags sought)

-- |The mighty consperse function
consperse :: [a] -> [[a]] -> [a]
consperse sep items = concat (intersperse sep items)

-- |cartesianProduct [[1,2,3], [4,5],[6]] -> [[1,4,6],[1,5,6],[2,4,6],[2,5,6],[3,4,6],[3,5,6]]
cartesianProduct [] = []
cartesianProduct [xs] = map (: []) xs
cartesianProduct (xs : yss) =
    distribute xs (cartesianProduct yss)
    where distribute xs yss = concat (map (\ x -> map (x :) yss) xs)

-- Example:
--
-- let (optSpecs :: [OptDescr Flag]) =
--     [Option [] ["verbose"]	(ReqArg (Param "Verbose") "NUMBER")
--	"Specify the amount of debugging output",
--	Option ['n'] ["dry-run"]	(NoArg (Param "Dry-Run" "yes"))
--	"Test run, don't modify the repository."]
-- flags <- computeConfig "myapp" optSpecs Nothing >>= return . head
-- let dryRun = findBool flags "Dry-Run"
--     verbose = maybe 0 read (findParam flags "Verbose")
--

-- When this is executed, it will load either the configuration file
-- ~/.myapp.conf, /etc/myapp.conf, or some configuration file
-- specified using the --config command line app.  The top section of
-- the configuration file will be merged with the command line flags.
-- Then those flags are expanded using the rules described in the
-- definition of the Flag datatype, and the result is returned.