bamse-0.9.4: 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 Data.Maybe
import Bamse.Options
import System.Directory

-- 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, _ienv) <- 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         = opt_ienv opts
		, 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 (p_ienv pkg')
	    , w_srcDir      = normalise (takeDirectory (srcDir $ p_ienv pkg'))
	    , 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 (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 f of
        Nothing  -> return ()
	Just fnm -> do
          let cmd = ("copy /b \"" ++ fnm ++ "\" \"" ++ 
	             appendP outDir (dropDirPrefix topDir fnm) ++ "\" > nul")
          system cmd
          return ()
    copyOver outDir (Directory fp subs) = do
       maybe (return ())
             (\ f -> system ("mkdir " ++ appendP outDir (dropDirPrefix topDir f)) >> return ())
	     (fn fp)
       mapM_ (copyOver outDir) subs

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