bamse-0.9.5: Bamse/Builder.hs

--------------------------------------------------------------------
-- |
-- Module      : Bamse.Builder
-- Description : Toplevel module for a bamse library/app.
-- Copyright   : (c) Sigbjorn Finne, 2004-2009
-- License     : BSD3
--
-- Maintainer  : Sigbjorn Finne <sof@forkIO.com>
-- Stability   : provisional
-- Portability : portable
--
-- Toplevel module for the @Bamse@ library/app. Use @genBuilder@
-- to do the generation of an MSI; it taking a specification of the
-- installer you are wanting to create. That along with the command-line
-- settings are then used to kick off the creation of an MSI database,
-- which will incorporate not only the metadata (installer name, shortcuts etc.)
-- but also the file content and structure that makes up the tree of
-- files you want to install on the user's machine.
-- 
--------------------------------------------------------------------
module Bamse.Builder 
       ( genBuilder 
       , genBuilderArgs
       ) where

import Bamse.Package
import Bamse.Writer
import Bamse.IMonad
import Bamse.PackageGen
import Bamse.MSIExtra
import Bamse.PackageUtils
import Bamse.DialogUtils

import System.Win32.Com ( coRun )
import System.FilePath
import Bamse.Util.Dir
import Bamse.Util.List ( ifCons )

import System.Cmd
import System.IO
import Bamse.Options

import Data.Maybe
import Control.Monad
import System.Directory
import System.Exit

-- ToDo:
--     - ability to organise installed bits into features/sub parts.
-- 

-- | @genBuilderArgs pkg argv@ constructs an MSI from the given package
-- description + a set of command-line of arguments @args@.
genBuilderArgs :: PackageData -> [String] -> IO ()
genBuilderArgs pkg args = do
  opts      <- getOptionsFrom args (p_defOutFile pkg)
  genBuilderOpts pkg opts

-- | @genBuilder pkg @ constructs an MSI from the given package
-- description, plus taking the command-line arguments from @getArgs@.
genBuilder :: PackageData -> IO ()
genBuilder pkg = do
  putStrLn ("Installer builder for: " ++ name (p_pkgInfo pkg)) >> hFlush stdout
  opts           <- getOptions (p_defOutFile pkg)
  genBuilderOpts pkg opts

genBuilderOpts :: PackageData -> Options -> IO ()
genBuilderOpts pkg opts = do
  ds              <- (p_fileMap pkg) (opt_ienv opts)
  (dsDist, ienvN) <- mkDistTree (opt_ienv opts)
                                (normalise $ dropTrailingPathSeparator $ srcDir $ opt_ienv opts)
  			        (name $ p_pkgInfo pkg)
				(p_distFileMap pkg)
  			        ds
  let pkg' = pkg{ p_files   = dsDist
		, p_dialogs = 
		       ifCons (p_userInstall pkg) setupTypeDialog $
		         ifCons (isJust (p_cabalPackage pkg)) (cabalDialog (fromJust (p_cabalPackage pkg))) $
--retired:	         ifCons (isJust (p_ghcPackage pkg)) ghcPkgDialog $
			   -- add customization selection dialog only if the
			   -- builder supplies the relevant features.
			  case options_ (opt_ienv opts) of
			    [] -> []
			    os -> [customizeDialog os]
  		, p_productGUID  = fromJust (opt_productGUID opts)
		, p_revisionGUID = fromJust (opt_revisionGUID opts)
		, p_ienv         = ienvN
		, p_verbose      = opt_verbose opts
  		}
  let bamseDir = toolDir (p_ienv pkg')
  coRun $ do
    (_, ts, tabs, reps) <-  doInstall [] (genTables pkg')
    let wenv = 
         WriterEnv 
            { w_toolDir     = bamseDir
   	    , w_templateDir = lFile (lFile bamseDir "data") "msi"
	    , w_outFile     = outFile ienvN
	       -- Note: using the _adjusted_ source directory here
	       -- from the dist tree, not the original one (i.e., want
	       -- to chop out the 'out/..' prefix, of course.)
	    , w_srcDir      = normalise (takeDirectory (srcDir ienvN))
	    , w_package     = pkg'
	    }
    outputMSI wenv tabs ts reps
    return ()
 where
  options_ ienv
   = ifCons (not (null (p_extensions pkg ienv)))
   	    ("Register file extensions", "OptFileExt", True) $
       ifCons (not (null (p_desktopShortcuts pkg ienv)))
              ("Create desktop shortcuts", "OptDesktopShortcuts", True) $
	 ifCons (not (null (snd $ p_startMenu pkg ienv)))
	        ("Create start menu folder", "OptStartMenu", True)
		[]


mkDistTree :: InstallEnv
	   -> FilePath
	   -> String
	   -> Maybe (InstallEnv -> FilePath -> Maybe FilePath)
	   -> DirTree
	   -> IO (DirTree, InstallEnv)
mkDistTree ienv _      _  Nothing   ds = return (ds, ienv)
mkDistTree ienv topDir nm (Just fn) ds = do
     -- copy over directory tree into temporary 'outDir'
    fp <- getCurrentDirectory
    catch (createDirectory (appendP fp "out")) (\ _ -> return ())
    let outDir = appendP fp (appendP "out" nm)
    catch (createDirectory outDir) (\ _ -> return ())
    copyOver outDir ds
    ds1 <- allFiles outDir
    return (ds1, ienv{srcDir=outDir})
  where
    copyOver _ Empty         = return ()
    copyOver outDir (File f) = do
      case fn ienv f of
        Nothing  -> return ()
	Just fnm -> do
          let cmd = ("copy /b \"" ++ f ++ "\" \"" ++ 
	             appendP outDir (dropDirPrefix topDir fnm) ++ "\" > nul")
--          putStrLn ("Creating dir: " ++ fnm ++ ' ':(dropFileName $ appendP outDir (dropDirPrefix topDir fnm)))
          createDirectoryIfMissing True (dropFileName $ appendP outDir (dropDirPrefix topDir fnm))
          system' cmd
          return ()
    copyOver outDir (Directory fp subs) = do
       maybe (return ())
             (\ f -> do
--                 putStrLn ("Creating dirs: " ++ fp ++ ' ':(appendP outDir (dropDirPrefix topDir f)))
	         createDirectoryIfMissing True (appendP outDir (dropDirPrefix topDir f))
		 return ())
	     (fn ienv fp)
       mapM_ (copyOver outDir) subs

    appendP a b = normalise (a </> b)

    system' cmd = do
--      when vb (hPutStrLn stderr ("Command exec: " ++ cmd))
      rc <- system cmd
      case rc of
       ExitSuccess{} -> return ()
       _ -> putStrLn $ "ERROR: failed exec'ing " ++ show cmd