{-# LANGUAGE LambdaCase #-}

module Main where

import System.Console.GetOpt
          (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo)
import System.Exit (exitSuccess, exitFailure)
import qualified System.Environment as Env
import System.FilePath

import System.Directory (doesDirectoryExist, doesFileExist,
#if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,5))
                         listDirectory
#else
                         getDirectoryContents
#endif
  )
import System.IO (hPutStrLn, stderr)
import System.Process (readProcess)

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 Control.Monad.Exception.Synchronous as E
import qualified Control.Monad.Trans.Class as T

import qualified Data.Set as Set
import Control.Monad (guard, when, unless)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Data.List (delete, intersperse, stripPrefix)
import Data.Version  (showVersion)

#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,2))
#else
import Control.Applicative ((<$>))
#endif

#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

import Paths_rpmbuild_order (version)

main :: IO ()
main =
  E.resolveT handleException $ do
  argv <- T.lift Env.getArgs
  let (opts, args, errors) = getOpt Permute options argv
  flags <-
    E.ExceptionalT $ return $
        foldr (=<<)
           (return
            Flags {optHelp = False,
                   optVersion = False,
                   optVerbosity = False,
                   optFormat = package,
                   optParallel = Nothing,
                   optBranch = Nothing})
           opts
  if optHelp flags
    then T.lift $ help >> exitSuccess
    else
    if optVersion flags
    then T.lift $ putStrLn $ showVersion version
    else
      if length args < 2
      then T.lift $ help >> exitFailure
      else do
        let (com:pkgs) = args
        unless (null errors) $ E.throwT $ concat errors
        unless (com `elem` ["sort", "deps", "rdeps"]) $
          E.throwT $ "Unknown command " ++ com
        runCommand flags com $ map (removeSuffix "/") pkgs
  where
    help =
      Env.getProgName >>= \programName ->
        putStrLn
             (usageInfo ("Usage: " ++ programName ++
                         " [OPTIONS] [sort|deps|rdeps] PKG-SPEC-OR-DIR ...") options)

handleException :: String -> IO ()
handleException msg = do
   putStrLn $ "Aborted: " ++ msg
   exitFailure

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

data Flags =
   Flags {
      optHelp :: Bool,
      optVersion :: Bool,
      optVerbosity :: Bool,
      optFormat :: SourcePackage -> String,
      optParallel :: Maybe String,
      optBranch :: Maybe FilePath
   }

options :: [OptDescr (Flags -> E.Exceptional String Flags)]
options =
  [
    Option ['h'] ["help"]
      (NoArg (\flags -> return $ flags{optHelp = True}))
      "Show options"
  , Option ['V'] ["version"]
      (NoArg (\flags -> return $ flags{optVersion = True}))
      "Show version"
  , Option ['p'] ["parallel"]
      (OptArg
        (\mstr flags ->
            fmap (\cs -> flags{optParallel = Just cs})
            (E.Success (fromMaybe "" mstr)))
         "SEPARATOR")
      "Display independently buildable groups of packages, optionally with separator"
  , Option ['b'] ["branch"]
      (ReqArg
         (\str flags ->
            fmap (\mb -> flags{optBranch = mb})
            (E.Success (Just str)))
         "BRANCHDIR")
    "branch directory"
  , Option ['f'] ["format"]
      (ReqArg
         (\str flags ->
            fmap (\select -> flags{optFormat = select}) $
            case str of
               "package" -> E.Success package
               "spec" -> E.Success location
               "dir"  -> E.Success (takeDirectory . location)
               _ ->
                  E.Exception $
                  "unknown info type " ++ str)
         "KIND")
      "output format: 'package' (default), 'spec', or 'dir'"
  , Option ['v'] ["verbose"]
      (NoArg
         (\flags ->
            return flags{optVerbosity = True}))
      "verbose output"
  ]

type Package = String

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

type Command = String

runCommand :: Flags -> Command -> [Package] -> E.ExceptionalT String IO ()
runCommand flags "sort" pkgs = sortSpecFiles flags pkgs
runCommand flags "deps" pkgs = depsSpecFiles False flags pkgs
runCommand flags "rdeps" pkgs = depsSpecFiles True flags pkgs
runCommand _ _ _ = E.throwT "impossible happened"

createGraphNodes :: Flags -> [Package] -> [Package] ->
               E.ExceptionalT String IO (Gr SourcePackage (), [Graph.Node])
createGraphNodes flags pkgs subset = do
  unless (all (`elem` pkgs) subset) $
    E.throwT "Packages must be in the current directory"
  specPaths <- T.lift $ catMaybes <$> mapM (findSpec (optBranch flags)) (filter (/= fromMaybe "" (optParallel flags)) pkgs)
  let names = map takeBaseName specPaths
  provs <-
     T.lift $
     mapM (readProvides (optVerbosity flags)) specPaths
  let resolves = zip names provs
  deps <-
     T.lift $
     mapM (getDepsSrcResolved (optVerbosity flags) 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 :: Flags -> [Package] -> E.ExceptionalT String IO ()
sortSpecFiles flags pkgs = do
      (graph, _) <- createGraphNodes flags pkgs []
      T.lift $
         case optParallel flags of
           Just s ->
             mapM_ ((putStrLn . unwords . (if null s then id else intersperse s) . map (optFormat flags)) . topsort' . subgraph graph)
                 (components graph)
           Nothing ->
             mapM_ (putStrLn . optFormat flags) $ topsort' graph
 
depsSpecFiles :: Bool -> Flags -> [Package] -> E.ExceptionalT String IO ()
depsSpecFiles rev flags pkgs = do
  allpkgs <- T.lift $ filter (\ f -> head f /= '.') <$> listDirectory "."
  (graph, nodes) <- createGraphNodes flags allpkgs pkgs
  let dir = if rev then Graph.suc' else Graph.pre'
  sortSpecFiles flags $ map package $ xdfsWith dir third nodes graph
  where
    third (_, _, c, _) = c

readProvides :: Bool -> FilePath -> IO [String]
readProvides verbose file = do
  when verbose $ hPutStrLn stderr file
  pkgs <- lines <$>
    rpmspec ["--rpms", "--qf=%{name}\n", "--define", "ghc_version any"] Nothing file
  let pkg = takeBaseName file
  return $ delete pkg pkgs

getDepsSrcResolved :: Bool -> [(String,[String])] -> FilePath -> IO [String]
getDepsSrcResolved verbose provides file =
  map (resolveBase provides) <$> do
      when verbose $ hPutStrLn stderr file
      -- ignore version bounds
      map (head . words) . lines <$>
        rpmspec ["--buildrequires", "--define", "ghc_version any"] Nothing file
  where
    resolveBase :: [(String,[String])] -> String -> String
    resolveBase provs br =
      case mapMaybe (\ (pkg,subs) -> if br `elem` subs then Just pkg else Nothing) provs of
        [] -> br
        [p] -> p
        ps -> error $ br ++ "is provided by: " ++ unwords ps

removeSuffix :: String -> String -> String
removeSuffix suffix orig =
  fromMaybe orig $ stripSuffix suffix orig
  where
    stripSuffix sf str = reverse <$> stripPrefix (reverse sf) (reverse str)

cmdStdIn :: String -> [String] -> String -> IO String
cmdStdIn c as inp = removeTrailingNewline <$> readProcess c as inp
  where
    removeTrailingNewline :: String -> String
    removeTrailingNewline "" = ""
    removeTrailingNewline str =
      if last str == '\n'
      then init str
      else str

cmd :: String -> [String] -> IO String
cmd c as = cmdStdIn c as ""

rpmspec :: [String] -> Maybe String -> FilePath -> IO String
rpmspec args mqf spec = do
  let qf = maybe [] (\ q -> ["--queryformat", q]) mqf
  cmd "rpmspec" (["-q"] ++ args ++ qf ++ [spec])

getDeps :: Gr SourcePackage () -> [(SourcePackage, [SourcePackage])]
getDeps gr =
    let c2dep :: Graph.Context SourcePackage () -> (SourcePackage, [SourcePackage])
        c2dep ctx =
           (Graph.lab' ctx,
            map (Graph.lab' . Graph.context gr) (Graph.pre gr . Graph.node' $ ctx))
    in  Graph.ufold (\ctx ds -> c2dep ctx : ds) [] gr

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 () ->
   E.ExceptionalT String m ()
checkForCycles graph =
   case getCycles graph of
      [] -> return ()
      cycles ->
         E.throwT $ 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 (\case
              _:_:_ -> True
              _ -> False)
   . scc