-----------------------------------------------------------------------------
-- |
-- Module      :  Main
-- Copyright   :  (c) Andrea Rossato 2007
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  andrea.rossato@unibz.it
-- Stability   :  stable
-- Portability :  portable
--
--
-- HSlackBuilder is a script to automatically generate slackBuild
-- scripts from a cabal package
--
-----------------------------------------------------------------------------

module Main where

import Prelude hiding (catch)
import Control.Exception
import Control.Monad
import Data.IORef
import Distribution.Package            ( PackageIdentifier (..)
                                       , PackageName(..)
                                       , Dependency (..)              )
import Distribution.PackageDescription ( GenericPackageDescription(..)
                                       , PackageDescription(..)      )
import Distribution.PackageDescription.Configuration
                                       ( finalizePackageDescription  )
import Distribution.PackageDescription.Parse
                                       ( readPackageDescription      )
import Distribution.Simple.Compiler
import Distribution.Simple.Configure   ( configCompiler              )
import Distribution.Simple.Program     ( defaultProgramConfiguration )
import Distribution.System
import Distribution.Text
import Distribution.Verbosity          ( normal                      )
import Distribution.Version            ( Version                     )
import Foreign.C
import System.Cmd
import System.Console.GetOpt
import System.Directory
import System.Environment
import System.Exit
import System.FilePath.Posix
import System.Posix.Files              ( fileExist                   )

import Distribution.Slackware.SlackBuild

main :: IO ()
main = do
  args  <- getArgs
  (o,f) <- getOpts args
  i     <- newIORef (defaultSlackBuildConfig,False)

  doOpts i o
  (c,b) <- readIORef i
  (ghc, _) <- configCompiler (Just GHC) Nothing Nothing
              defaultProgramConfiguration normal
  (name,set,gpd) <- case f of
           [cf] -> do (n,s,t,dir) <- checksCabalPackage cf
                      putStrLn (t </> n <.> "cabal")
                      d  <- readPackageDescription normal (t </> n <.> "cabal")
                      removeDirectoryRecursive dir
                      return (n,s,d)
           _     -> error $ "No Cabal package specified!\n" ++ usage
  let conf = c { setup = set }
      pd   = finalizePackageDescription [] (const True) (Platform (read $ arch conf) Linux)
             (compilerId ghc) (buildDepends (packageDescription gpd)) gpd
  case pd of
    Right (d,_) -> do
            putStrLn $ "writing " ++ name <.> "SlackBuild" ++ "..."
            writeFile (name <.> "SlackBuild") $ slackBuild  conf d
            putStrLn $ "writing doinst.sh..."
            writeFile "doinst.sh"             $ slackDoInst conf d
            putStrLn $ "writing slack-desc..."
            writeFile "slack-desc"            $ slackDesc   conf d
            when b $ do
                 putStrLn $ "writing slack-required..."
                 writeFile "slack-required"   $ slackRequired    d
            putStrLn $ "Done!"
    Left mis     -> do
            putStrLn "Missing dependencies:"
            printDepList mis

checksCabalPackage :: FilePath -> IO (String,FilePath,FilePath,FilePath)
checksCabalPackage file = do
  let name = takeFileName file
      pid  = takeBaseName . takeBaseName $ name
  (n,_) <- checkName pid
  tmp   <- getTemporaryDirectory
  tmpd  <- mkdtemp $ tmp </>"hslackbuilder-XXXXXX"
  let tmpf = tmpd </> pid
  _ <- rawSystem "tar" ["-C",tmpd,"-xzf",file]  `catch`
                \(SomeException _) -> error $ "could not extract " ++ file
  -- check the setup script
  b <- fileExist (tmpf </> "Setup.hs")
  set <- if b
         then return "Setup.hs"
         else do
           b' <- fileExist (tmpf </> "Setup.lhs")
           unless b' $ error ("Cannot find a valid Setup file in the cabal package " ++ file)
           return "Setup.lhs"
  return (n,set,tmpf,tmpd)

checkName :: FilePath -> IO (String, Version)
checkName f = do
  PackageIdentifier (PackageName n) v <- case simpleParse f of
	                                   Just i -> return i
	                                   _      -> error $ "malformed package identifier " ++ f
  return (n,v)

printDepList :: [Dependency] -> IO ()
printDepList [] = return ()
printDepList ((Dependency s v):xs) = do
    putStrLn $ (show s) ++ show v
    printDepList xs

-- C stuff
foreign import ccall unsafe "stdlib.h mkdtemp"
  c_mkdtemp :: CString  -> IO CString

-- | Create a temp directory with a template: temp-XXXXXX
-- I'm sure there was something similar in Haskell, but I'm not able
-- to find it!
mkdtemp :: String -> IO String
mkdtemp t = do
  withCString t $ \c_s -> do
      e <- c_mkdtemp c_s
      peekCString e

-- The needed boilerplate code for parsing command line options

data Opts = Help
          | Version
          | LinkSource
          | SlackRequired
          | HsColour String
          | UsePrefix
          | Build String
          | Arch String
       deriving Show

options :: [OptDescr Opts]
options =
    [ Option ['h','?' ] ["help"        ] (NoArg  Help                  ) "This help"
    , Option ['V'     ] ["version"     ] (NoArg  Version               ) "Show version information"
    , Option ['b'     ] ["build-number"] (ReqArg Build "build number"  ) "The build number"
    , Option ['a'     ] ["arch"        ] (ReqArg Arch "architecture"   ) "The architecture"
    , Option ['l'     ] ["link"        ] (NoArg  LinkSource            ) "The Haddock documentation will link the source code"
    , Option ['p'     ] ["hs-prefix"   ] (NoArg  UsePrefix             ) "Use a 'hs-' prefix in package name to avoid conflicts with\nslackware package names"
    , Option ['r'     ] ["required"    ] (NoArg  SlackRequired         ) "Generate a slack-required from the dependency field"
    , Option ['c'     ] ["hs-colour"   ] (ReqArg HsColour "path to css") "The source code will be colorize with hs-colour"
    ]

getOpts :: [String] -> IO ([Opts], [String])
getOpts argv =
    case getOpt Permute options argv of
      (o,n,[])   -> return (o,n)
      (_,_,errs) -> error (concat errs ++ usage)

usage :: String
usage = (usageInfo header options) ++ footer
    where header = "Usage: cabal2slackBuild [OPTION...] FILE\n" ++
                   "The file must be a .tar.gz of a cabal package.\n" ++
                   "Options:"
          footer = "\nMail bug reports and suggestions to " ++ mail

version :: String
version = "cabal2slackBuild 0.0.2 (C) 2008 Andrea Rossato " ++ mail ++ legal

mail :: String
mail = "<andrea.rossato@unitn.it>\n"

legal :: String
legal = "\nThis program is distributed in the hope that it will be useful,\n" ++
        "but WITHOUT ANY WARRANTY; without even the implied warranty of\n" ++
        "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n" ++
        "See the License for more details."

doOpts :: IORef (SlackBuildConfig,Bool) -> [Opts] -> IO ()
doOpts _  [] = return ()
doOpts conf (o:oo) =
    case o of
      Help          -> putStr   usage   >> exitWith ExitSuccess
      Version       -> putStrLn version >> exitWith ExitSuccess
      LinkSource    -> modifyIORef conf (\(c,b) -> (c { linkSource = True   },b   )) >> go
      UsePrefix     -> modifyIORef conf (\(c,b) -> (c { usePrefix  = True   },b   )) >> go
      SlackRequired -> modifyIORef conf (\(c,_) -> (c                        ,True)) >> go
      HsColour s    -> modifyIORef conf (\(c,b) -> (c { hscolour   = s      },b   )) >> go
      Build    s    -> modifyIORef conf (\(c,b) -> (c { build      = read s },b   )) >> go
      Arch     s    -> modifyIORef conf (\(c,b) -> (c { arch       = s      },b   )) >> go
    where
      go = doOpts conf oo