{-# LANGUAGE CPP #-}

import Data.Graph.Inductive.Query.DFS (xdfsWith, topsort', scc, components)
import Data.Graph.Inductive.Tree (Gr)
import qualified Data.Graph.Inductive.Graph as Graph

import qualified Data.Set as Set
import Control.Applicative (some,
#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,0))
#else
                            (<$>), (<*>)
#endif
                           )
import Control.Monad (guard, when, unless)
import qualified Data.ByteString.Char8 as B
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Data.List (delete)
import Options.Applicative (str)
import System.Directory (doesDirectoryExist, doesFileExist,
#if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,5))
                         listDirectory
#else
                         getDirectoryContents
#endif
  )
import System.Exit (ExitCode (..), exitFailure)
import System.FilePath
-- replace with warning
import System.IO (hPutStrLn, stderr)
import System.Process (readProcessWithExitCode)

import SimpleCmdArgs
import Paths_rpmbuild_order (version)

#if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,5))
#else
listDirectory :: FilePath -> IO [FilePath]
listDirectory path =
  filter f <$> getDirectoryContents path
  where f filename = filename /= "." && filename /= ".."
#endif

main :: IO ()
main =
  simpleCmdArgs (Just version) "Order packages by build dependencies"
  "Sort package sources (spec files) in build dependency order" $
  subcommands
  [ Subcommand "sort" "sort packages" $
    sortSpecFiles <$> verboseOpt <*> lenientOpt <*> parallelOpt <*> subdirOpt <*> pkgArgs
  , Subcommand "deps" "sort dependencies" $
    depsSpecFiles False <$> verboseOpt <*> lenientOpt <*> parallelOpt <*> subdirOpt <*> pkgArgs
  , Subcommand "rdeps" "sort dependents" $
    depsSpecFiles True <$> verboseOpt <*> lenientOpt <*> parallelOpt <*> subdirOpt <*> pkgArgs
  ]
  where
    verboseOpt = switchWith 'v' "verbose" "Verbose output for debugging"
    lenientOpt = switchWith 'l' "lenient" "Ignore rpmspec errors"
    parallelOpt = switchWith 'p' "parallel" "Separate independent packages"
    subdirOpt = optional (strOptionWith 'd' "dir" "SUBDIR" "Branch directory")
    pkgArgs = some (argumentWith str "PKG...")

findSpec :: Maybe FilePath -> FilePath -> IO (Maybe FilePath)
findSpec mdir file =
  if takeExtension file == ".spec"
    then checkFile file
    else do
    dirp <- doesDirectoryExist file
    if dirp
      then
      let dir = maybe file (file </>) mdir
          pkg = takeBaseName file in
        checkFile $ dir </> pkg ++ ".spec"
      else error $ "No spec file found for " ++ file
  where
    checkFile :: FilePath -> IO (Maybe FilePath)
    checkFile f = do
      e <- doesFileExist f
      if e
        then return $ Just f
        else return Nothing

type Package = B.ByteString

data SourcePackage =
   SourcePackage {
      location :: FilePath,
      package :: Package,
      dependencies :: [Package]
   }
   deriving (Show, Eq)

createGraphNodes :: Bool -> Bool -> Maybe FilePath -> [Package] -> [Package] ->
                    IO (Gr SourcePackage (), [Graph.Node])
createGraphNodes verbose lenient mdir pkgs subset = do
  unless (all (`elem` pkgs) subset) $
    error "Packages must be in the current directory"
  specPaths <- catMaybes <$> mapM (findSpec mdir . B.unpack) pkgs
  let names = map (B.pack . takeBaseName) specPaths
  resolves <- catMaybes <$> mapM (readProvides verbose lenient) specPaths
  deps <- catMaybes <$> mapM (getDepsSrcResolved verbose lenient resolves) specPaths
  let spkgs = zipWith3 SourcePackage specPaths names deps
      graph = getBuildGraph spkgs
  checkForCycles graph
  let nodes = Graph.labNodes graph
      subnodes = mapMaybe (pkgNode nodes) subset
  return (graph, subnodes)
  where
    pkgNode [] _ = Nothing
    pkgNode ((i,l):ns) p = if p == package l then Just i else pkgNode ns p

sortSpecFiles :: Bool -> Bool -> Bool -> Maybe FilePath -> [Package] -> IO ()
sortSpecFiles verbose lenient parallel mdir pkgs = do
      (graph, _) <- createGraphNodes verbose lenient mdir pkgs []
      if parallel then
        mapM_ ((B.putStrLn . B.cons '\n' . B.unwords . map package) . topsort' . subgraph graph) (components graph)
        else mapM_ (B.putStrLn . package) $ topsort' graph

depsSpecFiles :: Bool -> Bool -> Bool -> Bool -> Maybe FilePath -> [Package] -> IO ()
depsSpecFiles rev verbose lenient parallel mdir pkgs = do
  allpkgs <- map B.pack . filter (\ f -> head f /= '.') <$> listDirectory "."
  (graph, nodes) <- createGraphNodes verbose lenient mdir allpkgs pkgs
  let direction = if rev then Graph.suc' else Graph.pre'
  sortSpecFiles verbose lenient parallel mdir $ map package $ xdfsWith direction third nodes graph
  where
    third (_, _, c, _) = c

readProvides :: Bool -> Bool -> FilePath -> IO (Maybe (Package,[Package]))
readProvides verbose lenient file = do
  when verbose $ hPutStrLn stderr file
  mpkgs <- rpmspecQuery lenient ["-q", "--provides", "--define", "ghc_version any"] file
  case mpkgs of
    Nothing -> return Nothing
    Just pkgs ->
      let pkg = B.pack $ takeBaseName file in
        return $ Just (pkg, delete pkg pkgs)

getDepsSrcResolved :: Bool -> Bool -> [(Package,[Package])] -> FilePath -> IO (Maybe [Package])
getDepsSrcResolved verbose lenient provides file = do
  when verbose $ hPutStrLn stderr file
  fmap (map resolveBase) <$>
    rpmspecQuery lenient ["--buildrequires", "--define", "ghc_version any"] file
  where
    resolveBase :: Package -> Package
    resolveBase br =
      case mapMaybe (\ (pkg,subs) -> if br `elem` subs then Just pkg else Nothing) provides of
        [] -> br
        [p] -> p
        ps -> error $ B.unpack br ++ " is provided by: " ++ (B.unpack . B.unwords) ps

getBuildGraph :: [SourcePackage] -> Gr SourcePackage ()
getBuildGraph srcPkgs =
   let nodes = zip [0..] srcPkgs
       nodeDict = zip (map package srcPkgs) [0..]
       edges = do
          (srcNode,srcPkg) <- nodes
          dstNode <- mapMaybe (`lookup` nodeDict) (dependencies srcPkg)
          guard (dstNode /= srcNode)
          return (dstNode, srcNode, ())
   in Graph.mkGraph nodes edges

checkForCycles :: Monad m => Gr SourcePackage () -> m ()
checkForCycles graph =
   case getCycles graph of
      [] -> return ()
      cycles ->
        error $ unlines $
        "Cycles in dependencies:" :
        map (unwords . map location . nodeLabels graph) cycles

nodeLabels :: Gr a b -> [Graph.Node] -> [a]
nodeLabels graph =
   map (fromMaybe (error "node not found in graph") .
        Graph.lab graph)

subgraph :: Gr a b -> [Graph.Node] -> Gr a b
subgraph graph nodes =
   let nodeSet = Set.fromList nodes
       edges = do
           from <- nodes
           (to, lab) <- Graph.lsuc graph from
           guard $ Set.member from nodeSet && Set.member to nodeSet
           return (from,to,lab)
   in  Graph.mkGraph (zip nodes $ nodeLabels graph nodes) edges

getCycles :: Gr a b -> [[Graph.Node]]
getCycles =
   filter ((>= 2) . length) . scc

-- returns the first word for each line
rpmspecQuery :: Bool -> [String] -> FilePath -> IO (Maybe [B.ByteString])
rpmspecQuery lenient args spec = do
  (res, out, err) <- readProcessWithExitCode "rpmspec" (["-q"] ++ args ++ [spec]) ""
  unless (null err) $ hPutStrLn stderr err
  case res of
    ExitFailure _ -> if lenient then return Nothing else exitFailure
    ExitSuccess -> return $ Just $ map takeFirst $ B.lines (B.pack out)
  where
    -- ignore version bounds
    takeFirst :: B.ByteString -> B.ByteString
    takeFirst = head . B.words