bamse-0.9.1: Bamse/Builder.hs

--
-- (c) 2007, Galois, Inc.
--
-- Toplevel module for bamse library/app.
-- 
-- Bamse - a batch MSI installer creator.
--
-- ToDo:
--     - ability to organise installed bits into features/sub parts.
-- 
module Bamse.Builder ( genBuilder ) 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 IO
import Util.Path ( dirname, appendSep, toPlatformPath, joinPath, splitPath, appendPath )
import Util.Dir
import Util.List ( ifCons )

import System 
import IO
import Monad   ( when )
import Maybe
import Bamse.Options
import System.Directory

genBuilder :: PackageData -> IO ()
genBuilder pkg = do
  putStrLn ("Installer builder for: " ++ name (p_pkgInfo pkg)) >> hFlush stdout
  opts           <- getOptions (p_defOutFile pkg)
  ds             <- (p_fileMap pkg) (opt_ienv opts)
  (dsDist, ienv) <- mkDistTree (opt_ienv opts)        (srcDir $ opt_ienv opts)
  			       (name $ p_pkgInfo pkg) (p_distFileMap pkg)
  			       ds
  let pkg' = pkg{ p_files   = dsDist
		, p_dialogs = 
		       (if p_userInstall pkg
		         then (setupTypeDialog:)
			 else if isJust (p_ghcPackage pkg)
			  then (ghcPkgDialog:)
			  else id) $
			   -- 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 env = 
         WriterEnv 
            { w_toolDir     = bamseDir
   	    , w_templateDir = lFile (lFile bamseDir "data") "msi"
	    , w_outFile     = outFile (p_ienv pkg')
	    , w_srcDir      = dirname (srcDir $ p_ienv pkg')
	    , w_package     = pkg'
	    }
    outputMSI env 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
    ds <- allFiles outDir
    return (ds, ienv{srcDir=outDir})
  where
    copyOver _ Empty         = return ()
    copyOver outDir (File f) = do
      case fn f of
        Nothing -> return ()
	Just f  -> do
          let cmd = ("copy /b \"" ++ f ++ "\" \"" ++ 
	             appendP outDir (dropDirPrefix topDir f) ++ "\" > nul")
          system cmd
          return ()
    copyOver outDir (Directory fp subs) = do
       case fn fp of
         Nothing -> return ()
	 Just fp -> system ("mkdir " ++ appendP outDir (dropDirPrefix topDir fp)) >> return ()
       mapM_ (copyOver outDir) subs

    appendP a b = toPlatformPath $ appendPath a b