--------------------------------------------------------------------
-- |
-- Module      : Bamse.PackageGen
-- Description : Given a package specification, generate the MSI tables.
-- Copyright   : (c) Sigbjorn Finne, 2004-2009
-- License     : BSD3
--
-- Maintainer  : Sigbjorn Finne <sof@forkIO.com>
-- Stability   : provisional
-- Portability : portable
--
-- Given a package specification, generate the MSI tables.
-- 
--------------------------------------------------------------------
module Bamse.PackageGen where

import Bamse.Package
import Bamse.MSIExtra
import Bamse.MSITable hiding ( File ) --ColumnValue(File) )
import Bamse.IMonad
import Bamse.DiaWriter
import Bamse.PackageUtils ( dropDirPrefix )

import Util.Dir
import Util.Path
import Util.List
import Data.Maybe   ( isJust, isNothing, fromJust )

import System.IO     ( openFile, IOMode(..), hFileSize, hClose )
import Control.Monad ( when, zipWithM_ )
import Debug.Trace

--
fileSize :: FilePath -> IO Integer
fileSize fPath = do
    h   <- openFile fPath ReadMode
    fsz <- hFileSize h
    hClose h
    return fsz

genTables :: PackageData -> IM ()
genTables pkg_data = do
   mkFileTables pkg_data  (p_files pkg_data)
   addRegistryEntries     (p_registry pkg_data)
   addStartMenuShortcuts  (p_baseFeature pkg_data) (p_ienv pkg_data) (p_startMenu pkg_data ienv)
   addDesktopShortcuts    (p_baseFeature pkg_data) (p_ienv pkg_data) (p_desktopShortcuts pkg_data ienv)
   makeShortcutsOptional
   addFileExtensions      (fst $ p_baseFeature pkg_data) (p_extensions pkg_data ienv)
   addVerbs		  (p_verbs pkg_data)
   configureLicense	  (p_license pkg_data ienv)
   setUserRegistration    (p_userRegistration pkg_data)
   setCustomTargetDir     (p_defaultInstallFolder pkg_data)
   			  (name (p_pkgInfo pkg_data))
   when (not (p_notForAll pkg_data)) setCustomAllUsers
      --"Please remember to add [TARGETDIR]bin to your PATH."
   replaceFinishedText    (p_finalMessage pkg_data)
      --"Default installation directory: [TARGETDIR]"
   addDestText            
   setURL		  (p_webSite pkg_data)
   addBannerBitmap        "packageBanner" (p_bannerBitmap pkg_data ienv)
   addDialogBitmap        "bgBanner"      (p_bgroundBitmap pkg_data ienv)
   when (isJust (p_ghcPackage pkg_data))
        (setupGhcPackage (fromJust (p_ghcPackage pkg_data)))
   mapM_ (writeDialog pkg_data (p_ghcPackage pkg_data) (isJust $ p_license pkg_data ienv))
         (p_dialogs pkg_data)
   addFiles
   addFeatures		  (p_baseFeature pkg_data) (p_featureMap pkg_data) (p_features pkg_data)
   addRegSearch 	  (p_ghcPackage pkg_data)
   addServices            (p_services pkg_data)
   addNestedInstalls      (p_nestedInstalls pkg_data)
 where
  ienv = p_ienv pkg_data

addServices ls = 
  case ls of
    [] -> return ()
    _  -> do
      mapM_ addServ ls
 where
  addServ s = do
     v <- newId
     let sKey = idToKey v
     dirs  <- getDirs
     comps <- getComponents
     let theBinary 
          | null (fileSuffix (serv_binary s)) = changeSuffix ".exe" (serv_binary s) 
	  | otherwise = serv_binary s
     let cKey = findExeComponent dirs comps theBinary
	 user_pwd = 
	   case serv_user_pwd s of
	     Nothing    -> []
	     Just (u,p) -> [ "StartName" -=> Just (string u)
	     		   , "Password"  -=> Just (string p)
			   ]
	 args = 
	   case serv_args s of
	     [] -> []
	     ss -> [ "Arguments" -=> Just (string (unwords ss)) ]
     when (cKey == theBinary)
          (ioToIM $ do
	    putStrLn ("WARNING: unable to locate service binary " ++ theBinary)
	    print comps)
     addRow (newServiceInstall
     		          (user_pwd ++ args ++
     			   [ "ServiceInstall" -=> Just (string sKey)
     			   , "Name"           -=> Just (string (serv_name s))
			   , "DisplayName"    -=> Just (string (serv_dispName s))
			   , "ServiceType"    -=> Just (int (serv_type s))
			   , "StartType"      -=> Just (int (serv_start s))
			   , "ErrorControl"   -=> Just (int (serv_error s))
			   , "Component_"     -=> Just (string cKey)
			   , "Description"    -=> Just (string (serv_descr s))
			   ]))
	-- All services that are installed will be removed during uninstall.
	-- Make it so.
     v <- newId
     let tKey = idToKey v			   
     addRow (newServiceControl
     			  ([ "ServiceControl" -=> Just (string tKey)
			   , "Name"           -=> Just (string (serv_name s))
			   , "Event"          -=> Just (int (0x80 + 0x3)) {- start/stop on (un)install, uninst-delete -}
			   , "Component_"     -=> Just (string cKey)
			   ]))

-- testing Registry searching..look for a GHC installation.
addRegSearch ghcPackage 
 | isNothing ghcPackage = return ()
 | otherwise = do
   let pkg = fromJust ghcPackage
   sId <- newId
   let installDirKey = idToKey sId
   sId <- newId
   let ghcPkgDirKey = idToKey sId
   addRow (newAppSearch [ "Property"   -=> Just (string "GHCPKGDIR")
   		        , "Signature_" -=> Just (string ghcPkgDirKey)
			])
   addRow (newAppSearch [ "Property"   -=> Just (string "GhcInstallDir")
   		        , "Signature_" -=> Just (string installDirKey)
			])
   addRow (newRegLocator [ "Signature_"  -=> Just (string installDirKey)
   			 , "Root"        -=> Just (int 2)  -- HKLM
			 , "Key"         -=> Just (string ("Software\\Haskell\\GHC\\ghc-"++ ghc_forVersion pkg))
			 , "Name"        -=> Just (string "InstallDir")
			 , "Type"        -=> Just (int 2) -- 'Key' is a key.
			 ])
   addRow (newDrLocator [ "Signature_" -=> Just (string ghcPkgDirKey)
   			, "Parent"     -=> Just (string installDirKey)
   			, "Path"       -=> Just (string "bin\\")
			])
   addRow (newSignature [ "Signature"  -=> Just (string ghcPkgDirKey)
   			, "FileName"   -=> Just (string "ghc-pkg.exe")
			])
   addRow (newSignature [ "Signature"  -=> Just (string installDirKey)
     			, "FileName"   -=> Just (string "ghc-pkg.exe")
			])

--
-- Function: mkFileTables
--
-- Purpose:  Given a directory tree, mkFileTables populates the
--           File and Directory tables
-- 
mkFileTables :: PackageData -> DirTree -> IM ()
mkFileTables pkg dTree =
  case dTree of
    Empty                -> return ()
    Util.Dir.File l      -> addDirOrFile pkg False l
    Directory dName subs -> addDirOrFile pkg True dName >> mapM_ (mkFileTables pkg) subs

--
-- Function: addDirOrFile
-- 
-- Purpose:  augment the MSI tables with the rows required for
--           the inclusion of a file or directory, mapping the 
--           file/dir to its 'component' in the process. 
--
-- We map files/directories to components as follows:
--
--    - each directory is a separate component.
--    - a 'special' file get a component of its own; 'special' is
--      an attribute determined by looking at the file's extension.
--      [ Treat some files as special since MSIs require file extensions,
--        shortcuts etc. need to be associated with their 'controlling'
--        component. I believe I've now put in enough smarts to require
--        treating these files specially, but no real harm done leaving
--        this bit in.
--      ]
--
-- Component table overflow/overload considerations aside, we could have a
-- 1-1 mapping between files/dirs and components. But, since each component 
-- needs to include the directory they belong to, it's just as easy to use
-- a more refined, directory-based mapping (modulo handling of 'special' 
-- files.)
--
addDirOrFile :: PackageData -> Bool -> FilePath -> IM ()
addDirOrFile pkg isDir fPath = do
    -- The 'controlling' directory of the file/dir. 
    -- For a file, the parent dir; for a directory, itself.
   let dName
        | isDir      = fPath
	| otherwise  = dirname fPath
   dirs  <- getDirs
   let mbDir = lookupDirectory dName dirs
   fileKey <- 
     if isDir
      then return (error "addDirOrFile: not supposed to happen")
      else fmap idToKey newId
    -- bind 'compKey' to the ID/key of component that 'controls'
    -- the file.
   compKey <- 
     if isJust mbDir && not (isCompWorthy fPath)
       -- If the controlling directory has already been created, and the file
       -- itself isn't 'special', look up its component key.
      then do
         comps <- getComponents
         return (findDirComponent (fromJust mbDir) comps)
      else do
	  -- Need to locate the component of the directory/file.
	  -- Easy for directories, each of them get a component of their own.

	  -- first off, create the ancestors.
         let sDir = srcDir (p_ienv pkg)
	 let dNameRel = dropDirPrefix (dirname sDir) dName
         createDirPath (p_verbose pkg) "TARGETDIR" (splitPath2 dNameRel)
	 let 
	  parentDir ds =
	    case lookupDirectory dNameRel ds of
	      Just x -> x
	      _      -> "TARGETDIR"
         dirs <- getDirs
	 let dirKey = parentDir dirs
	 when (null (shortLong (baseName dName))) 
	      (ioToIM (putStrLn ("empty: "++ show (dName, baseName dName))))
	 if isSpecialFile 
	  then do
            compKey  <- fmap idToKey newId
            compGUID <- newId
	    dirKeyN  <- newId
	    addRow (newDirectory 
		  [ "Directory"        -=> Just (string dirKeyN)
      		  , "Directory_Parent" -=> Just (string dirKey)
		  , "DefaultDir"       -=> Just (string ".")
      		  ])
	    addCompMapping compKey dirKeyN
	    addDirMapping  fPath dirKeyN
	    addRow (newComponent 
	      	       [ "Component"        -=> Just (string compKey)
      		       , "ComponentId"      -=> Just (string compGUID)
		       , "Directory_"       -=> Just (string dirKeyN)
		       , "Attributes"       -=> Just (int 0)
		       , "Condition"        -=> Just (string "")
		       , "KeyPath"          -=> Just (string (if not isDir then fileKey else ""))
		       ])
	    return compKey
	  else do
            comps <- getComponents
            return (findDirComponent dirKey comps)
     -- ..and finally, add file to the File table, associating the (possibly new)
     -- component key with it.
   when (not isDir) (do
          -- need to store the file size in the table; look it up.
	fsz <- ioToIM $ fileSize fPath
	when (p_verbose pkg) (ioToIM (putStrLn $ "Including: " ++ fPath))
	addFile fPath fileKey compKey (shortLong (baseName fPath)) (show fsz))
 where
  isSpecialFile = isCompWorthy fPath

   -- Files with certain file extensions get put into sep. components.
   -- See 'addDirOrFile' comments as to why this is done.
  isCompWorthy fpath = fileSuffix fpath `elem` ["exe", "dll", "ocx", "hlp"]

-- Go down a directory path, adding components for directories
-- that haven't been seen before.
createDirPath :: Bool -> String -> [String] -> IM ()
createDirPath _   _ []          = return ()
createDirPath flg parent (d:ds) = do
   dirs <- getDirs
   case lookupDirectory d dirs of
     Just{}  -> createDirPath flg d ds
     Nothing -> do
--debug:       ioToIM (putStrLn ("createDirPath: adding entry for " ++ show d))
       when flg (ioToIM (putStrLn $ "Including: " ++ d))
       cId      <- newId
       compGUID <- newId
       dirId    <- newId
       let compKey = idToKey cId
       let dirKey  = idToKey dirId
       addCompMapping compKey dirKey
       addDirMapping d dirKey
       let (Just parentDirKey) = 
       		case lookupDirectory parent dirs of
		  Nothing 
		   | parent == "TARGETDIR" -> Just parent
		   | otherwise -> error ("createDirPath: unable to locate parent " ++ show parent)
		  v -> v
       addRow (newDirectory 
		  [ "Directory"        -=> Just (string dirKey)
      		  , "Directory_Parent" -=> Just (string parentDirKey)
		  , "DefaultDir"       -=> 
		       Just (string ((if parent == "TARGETDIR" then (".:"++) else id) (shortLong (baseName d))))
      		  ])
       addRow (newComponent 
		  [ "Component"        -=> Just (string compKey)
      		  , "ComponentId"      -=> Just (string compGUID)
		  , "Directory_"       -=> Just (string dirKey)
		  , "Attributes"       -=> Just (int 0)
		  , "Condition"        -=> Just (string "")
		  , "KeyPath"          -=> Just (string "")
		  ])
       addRow (newCreateFolder
   	          [ "Directory_"   -=> Just (string dirKey)
	          , "Component_"   -=> Just (string compKey)
		  ])
       createDirPath flg d ds	   


--
-- Function: addFiles
-- 
-- Purpose:  at the very end of installation, the accumulated set
--           of files are converted into rows of the File table.
-- 
addFiles :: IM ()
addFiles = do
  fs <- getFiles
  mapM_ addF fs
 where
   addF (_,(fileKey, compKey, nm, fsz)) = 
        addRow (newFile [ "File" 	  -=>  Just (string fileKey)
      		        , "Component_"    -=>  Just (string compKey)
		        , "FileName"      -=>  Just (string nm)
		        , "FileSize"      -=>  Just (string fsz)
		        , "Version"       -=>  Just (string "")
		        , "Language"      -=>  Just (string "")
		        , "Attributes"    -=>  Just (int 0)
		        , "Sequence"      -=>  Just (int 1)
		        ])


--
-- Function: addFeatures
-- 
-- Purpose:  at the very end of installation, the accumulated set
--           of features and components are converted into rows of
--	     the Feature and FeatureComponents table.
-- 
addFeatures :: Feature
	    -> Maybe (FilePath -> FeatureName)
	    -> [Tree Feature]
	    -> IM ()
addFeatures bFeat featMap fs = do
  zipWithM_ (addFeatureTree Nothing) fs [(1::Int),3..]
  ls <- getComponents
  case featMap of
    Nothing -> mapM_ writeFeatComp ls
    Just f  -> mapM_ (writeFeatMapComp f) ls
 where
  baseFKey = idToKey (fst bFeat)

  writeFeatMapComp f (compKey, compName) = do
     addRow (newFeatureComponents [ "Feature_"     -=> Just (string baseFKey)
     			          , "Component_"   -=> Just (string compKey)
				  ])

  writeFeatComp (compKey, compName) = do
     addRow (newFeatureComponents [ "Feature_"     -=> Just (string baseFKey)
     			          , "Component_"   -=> Just (string compKey)
				  ])

  addFeatureTree parent tr lab = do
     case tr of
       Leaf f    -> addFeature parent lab f
       Node p@(id,_) fs -> do
          addFeature parent lab p
	  zipWithM_ (\ f u -> addFeatureTree (Just (idToKey id)) f (lab*10+u))
	  	    fs
		    [(1::Int),3..]

  addFeature mbParent v (featName, featDesc) = do
     let featKey = idToKey featName
     addRow (newFeature 
                       (("Feature"         -=> Just (string featKey)) :
     			 (case mbParent of
			   Just v -> (("Feature_Parent"  -=> Just (string v)):)
			   _      -> id) (
			   [ "Title"           -=> Just (string featName)
		           , "Description"     -=> Just (string featDesc)
		           , "Display"         -=> Just (int v)
		           , "Level"           -=> Just (int 1)
		           , "Directory_"      -=> Just (string "TARGETDIR")
		           , "Attributes"      -=> Just (int 0)
		           ])))

lookupDirectory :: FilePath -> [(FilePath, Id)] -> Maybe Id
lookupDirectory fPath ls = lookup fPath ls

findExeComponent dirs comps fpath = 
    -- be a bit flexible here & allow basename of the 
    -- app targets to be used.
    let dirs' = dirs ++ mapFst baseName dirs in
    case lookup fpath dirs' of
      Just c -> 
        case lookup c (map swap comps) of 
           -- want to map a dir to a comp, so swap (comp,dir) pairs.
	 Just x  -> x
	 Nothing -> fpath
      _ -> fpath

findDirComponent dir comps = 
 case lookup dir (map swap comps) of 
       -- want to map a dir to a comp, so swap (comp,dir) pairs.
   Just x  -> x
   Nothing 
--    | dir == "TARGETDIR" -> "TARGETDIR"
    | otherwise          -> error ("findDirComponent: couldn't locate " ++ show dir)

       -- want to map a dir to a comp, so swap (comp,dir) pairs.
mbFindDirComponent dir comps = lookup dir (map swap comps)

swap (a,b) = (b,a)

-- convert a unique (quite possibly, a GUID) Id into the key
-- name used when providing the 'key' entries of database rows.
idToKey :: Id -> String
idToKey ls = '_':stripName ls
 where
   stripName ('{':xs) = filter (/='-') (init xs)
   stripName nm       = nm

--
-- Function: addRegistryEntries
-- 
-- Purpose:  given a set of Registry entries, generate the 
-- 	     Registry table rows. All Registry entries are
--           put in a component of their own.
-- 
addRegistryEntries :: [RegEntry] -> IM ()
addRegistryEntries rs = do
   cId   <- newId
   cName <- newId
   let cKey = idToKey cName
     -- The registry entries gets a component all to themselves.
     -- (assuming that we can group more than one Reg key with 
     -- a component).
   addRow (newComponent 
   	      [ "Component"    -=> Just (string cKey)
	      , "ComponentId"  -=> Just (string cId)
	      , "Directory_"   -=> Just (string "TARGETDIR")
	      , "Attributes"   -=> Just (int 128) -- msidbComponentAttributesNeverOverwrite
	      , "Condition"    -=> Just (string "")
--	      , "KeyPath"      -=> Nothing
	      ])
   addCompMapping cKey "TARGETDIR"
   mapM_ (writeReg cKey cId) rs
 where
   writeReg cKey cId (RegEntry hive key kAction) = do
      rName <- newId
      let rKey      = idToKey rName
          (nm, val) = keyAction kAction
	  isInstallRemovable = 
	    case kAction of
	      DeleteKey True    -> True
	      DeleteName True _ -> True
	      _                 -> False

      case isInstallRemovable of
        True -> 
	 addRow (newRemoveRegistry
	 	    [ "RemoveRegistry" -=> Just (string rKey)
		    , "Root"           -=> Just (string (toHiveId hive))
		    , "Key"            -=> Just (string key)
		    , "Name"           -=> fmap string nm
		    , "Component_"     -=> Just (string cKey)
		    ])
	_ -> 
         addRow (newRegistry 
   		    [ "Registry"    -=>   Just (string rKey)
		    , "Root"        -=>   Just (string (toHiveId hive))
		    , "Key"         -=>   Just (string key)
		    , "Name"        -=>   fmap string nm
		    , "Value"       -=>   fmap string val
		    , "Component_"  -=>   Just (string cKey)
		    ])

   keyAction k = 
     case k of
       CreateKey True  -> (Just "*", Nothing)
       CreateKey False -> (Just "+", Nothing)
       DeleteKey{}     -> (Just "-", Nothing)
         -- Note: we always delete a key and everything underneath (not sure
	 -- what it means to only delete a key but not its descendants..)
       DeleteName _ nm -> (Just nm, Nothing)
       CreateName mbK val -> (mbK, Just val)

   toHiveId hive =
     case hive of
       "OnInstall" -> "-1" -- per-user or per-machine, dep. on selection at install-time.
       "HKCR"      -> "0"
       "HKCU"      -> "1"
       "HKLM"      -> "2"
       "HKU"       -> "3"
       _           -> "2" -- an error one might reasonably say;
       			  -- interpreted as HKLM, for now.

--
-- Function: addStartMenuShortcuts
--
-- Purpose:  Create a shortcuts folder inside the user's (?) portion
--	     of the start menu's program folder.
--
--           This function must be run after the components containing
--           the shortcut targets have been added as rows.
--
-- Comments: We intentionally do not support the creation of shortcuts
--           outside of the programs folder _and_ the shortcuts do
--           have to go into a separate folder.
-- 
addStartMenuShortcuts :: Feature
	              -> InstallEnv
		      -> ( String	-- name of folder the shortcuts will be created.
	                 , [Shortcut]
		         )
	              -> IM ()
addStartMenuShortcuts bFeat ienv (appFolders, scuts) 
  | null scuts = return ()
  | otherwise  = do
   -- add the start-menu folder directory.
  let sMenuKey = "StartMenuFolder"
  addRow (newDirectory [ "Directory"        -=>  Just (string sMenuKey)
  		       , "Directory_Parent" -=>  Just (string "TARGETDIR")
		       , "DefaultDir"       -=>  Just (string ".")
		       ])
   -- and the Programs sub-folder.
  let progKey = "ProgramMenuFolder"
  addRow (newDirectory [ "Directory"        -=>  Just (string progKey)
  		       , "Directory_Parent" -=>  Just (string "TARGETDIR")
		       , "DefaultDir"       -=>  Just (string ".")
		       ])
   -- and our app folder(s).
  let dirs = split '/' appFolders
      createDirs pKey [d] = do
        i <- newId
	let appKey = idToKey i
	addRow (newDirectory 
		   [ "Directory"        -=>  Just (string appKey)
  		   , "Directory_Parent" -=>  Just (string pKey)
		   , "DefaultDir"       -=>  Just (string (shortLong d))
		   ])
	return appKey
      createDirs pKey (d:ds) = do
         v <- createDirs pKey [d]
	 x <- createDirs v ds
	 return x
  appKey <- createDirs progKey dirs
{-
  i <- newId
  let appKey = idToKey i
  addRow (newDirectory [ "Directory"        -=>  Just (string appKey)
  		       , "Directory_Parent" -=>  Just (string progKey)
		       , "DefaultDir"       -=>  Just (string (shortLong appFolders))
		       ])
-}
  scuts' <- mapM (adjustTarget ienv (fst bFeat)) scuts
  mapM_ (addShortcut appKey) scuts'


makeShortcutsOptional = do
    -- Make the installation of shortcuts dependent on _either_ OptStartMenu or
    -- OptDesktopShortCuts being set to Yes. I don't see how to achieve the
    -- installation of start menu shortcuts without also installing the ones
    -- on the desktop...at least not with the current set of MSI tables and
    -- standard actions. Doing it via an custom action is a possibility, but 
    -- too much effort required for not enough added (subtracted?) functionality.
  let cond = "OptStartMenu=\"Yes\" OR OptDesktopShortcuts=\"Yes\""
  replaceRow ( "InstallExecuteSequence"
             , [ ("Action" -=> "CreateShortcuts")]
	     , [ ("Condition", Just (string cond))]
	     )
  replaceRow ( "InstallExecuteSequence"
             , [ ("Action" -=> "RemoveShortcuts")]
	     , [ ("Condition", Just (string cond))]
	     )


--
-- Function: addDesktopShortcuts
--
-- Purpose:  Create desktop shortcuts
--
--           This function must be run after the components containing
--           the shortcut targets have been added as rows.
--
-- 
addDesktopShortcuts :: Feature
		    -> InstallEnv
		    -> [Shortcut]
	            -> IM ()
addDesktopShortcuts bFeat ienv scuts = do
   -- add the start-menu folder directory.
  let dKey = "DesktopFolder"
  addRow (newDirectory [ "Directory"        -=>  Just (string dKey)
  		       , "Directory_Parent" -=>  Just (string "TARGETDIR")
		       , "DefaultDir"       -=>  Just (string ".")
		       ])
  scuts' <- mapM (adjustTarget ienv (fst bFeat)) scuts
  mapM_ (addShortcut dKey) scuts'

{-
 The user refers to the target of the shortcut by (file)name; the MSI
 wants to know the component (of that file).
-}
adjustTarget ienv feat s = do
  dirs  <- getDirs
  comps <- getComponents
    -- Try interpreting 'scut_target' as a directory relative to the srcDir.
    -- The directory list is recorded as relative to 'baseName' of the srcDir,
    -- so pin this in front of the user-specified directory.
  let bdir = baseName (srcDir ienv)
  let t    = scut_target s
  let tdir  
       | null t    = bdir
       | otherwise = appendPath bdir t
   -- Note: no need to put a slash between the two (indeed, it's harmful.)
  let odir = "[TARGETDIR]" ++ t
  let mbDir = lookupDirectory tdir dirs
  let mbComp = maybe Nothing (\ v -> mbFindDirComponent v comps) mbDir
  case mbComp of
    Just x -> return (odir, s{scut_target=x})
    Nothing ->
     let t = findExeComponent dirs comps (scut_target s) in
     if t == (scut_target s) then do
       -- couldn't find the component, try locating the file.
       ls <- getFiles 
       let ls' = map (\ st@(x,_) -> (x,st)) ls ++ map (\ st@(x,_) -> (baseName x, st)) ls
       case lookup t ls' of
         Nothing -> do
            ioToIM (putStrLn ("WARNING: unable to locate target " ++ show t))
	    return (featureKey, s)
         Just stuff@(f,(fKey,oldCompKey,nm,fSize)) -> do
           -- create a new component with keypath that points to target.
	    cId   <- newId 
	    cName <- newId 
	    let cKey = idToKey cName
	        dKey = case lookup oldCompKey comps of
	    	         Just x -> x
		         Nothing -> error ("couldn't locate component of file" ++ f)
	    addRow (newComponent
		   [ "Component" 	-=> Just (string cKey)
		   , "ComponentId"      -=> Just (string cId)
		   , "Directory_"       -=> Just (string dKey)
		   , "Attributes"       -=> Just (int 0)
		   , "Condition"        -=> Just (string "")
		   , "KeyPath"          -=> Just (string fKey)
		   ])
            addCompMapping cKey "TARGETDIR"
	     -- change the component of the target file (Q: what happens if there's
	     -- more than one shortcut target that points to the same file??)
	     -- Yes, that's problematic since the second time around we try to 'adjustTarget'
	     -- that file, its component key is now mapped to "TARGETDIR", which results
	     -- in a Directory_ mapping that's possibly wrong. 
	     --
	     -- Hence, disable this for now (and hope nothing goes awry..)
--	    replaceFile f (fKey, cKey, nm, fSize)
	    return (featureKey, s{scut_target=cKey})
     else 
       return (featureKey, s{scut_target=t})
 where
  featureKey = idToKey feat

addShortcut :: Key -> (String,Shortcut) -> IM ()
addShortcut appKey (featureKey,s) = do
  i  <- newId
  let key = idToKey i
  (iKey, idx) <- 
    case (scut_icon s) of
      Nothing -> return (Nothing, Nothing)
      Just f  -> addIcon f >>= \x -> return (Just (string x), Just (int 0))
  addRow (newShortcut [ "Shortcut"    -=>  Just (string key)
  		      , "Directory_"  -=>  Just (string appKey)
		      , "Name"        -=>  Just (string (scut_name s))
		      , "Component_"  -=>  Just (string (scut_target s))
		      , "Target"      -=>  Just (string featureKey)
		      , "Arguments"   -=>  Just (string (scut_args s))
		      , "Description" -=>  Just (string (scut_desc s))
--		      , "Hotkey"      -=>  Nothing
		      , "Icon_"       -=>  iKey
		      , "IconIndex"   -=>  idx
		      , "ShowCmd"     -=>  Just (int (scut_istate s))
		      , "WkDir"       -=>  Just (string (scut_wdir s))
		      ])

addIcon :: String -> IM Key
addIcon icoFile = do
  i <- newId
  let key = take 7 (idToKey i) ++ ".exe"
  addRow (newIcon [ "Name" -=> Just (string key)
  		  , "Data" -=> Just (file icoFile)
		  ])
  return key

setCustomTargetDir :: Maybe String -> String -> IM ()
setCustomTargetDir def pkgName = do
   addRow (newCustomAction
	      [ "Action"    -=>	Just (string "SET_TARGETDIR")
	      , "Type"      -=> Just (int 51)
	      , "Source"    -=> Just (string "TARGETDIR")
	      , "Target"    -=> case def of
				  Nothing -> Just (string ("[ProgramFilesFolder]"++pkgName))
				  Just x  -> Just (string x)
	      ])
   mapM_ (\ act -> addRow (act
			     [ "Action"    -=> Just (string "SET_TARGETDIR")
			     , "Condition" -=> Just (string "TARGETDIR=\"\"")
			     , "Sequence"  -=> Just (int 1)
			     ]))
	 [ newAdminExecuteSequence
	 , newAdminUISequence
	 , newInstallExecuteSequence
	 , newInstallUISequence
	 ]

-- the ALLUSERS property controls whether or not to do a
-- per-user or per-machine install.
setCustomAllUsers :: IM ()
setCustomAllUsers = do
   addRow (newCustomAction
	      [ "Action"    -=>	Just (string "SET_ALLUSERS")
	      , "Type"      -=> Just (int 51)
	      , "Source"    -=> Just (string "ALLUSERS")
	      , "Target"    -=> Just (int 2)
	      ])
   mapM_ (\ act -> addRow (act
			     [ "Action"    -=> Just (string "SET_ALLUSERS")
			     , "Condition" -=> Just (string "ALLUSERS=\"\"")
			     , "Sequence"  -=> Just (int 2)
			     ]))
	 [ newAdminExecuteSequence
	 , newAdminUISequence
	 , newInstallExecuteSequence
	 , newInstallUISequence
	 ]

replaceFinishedText Nothing    = return ()
replaceFinishedText (Just str) = do
    replaceRow ( "Control"
	       , [ "Dialog_" -=> "ExitDialog"
	         , "Control" -=> "Description"
		 ]
	       , [ "Text"    -=> Just (string str)
	         ]
               )
     -- only display the text when installing.
    addRow (newControlCondition
    	       [ "Dialog_"   -=> Just (string "ExitDialog")
    	       , "Control_"  -=> Just (string "Description")
	       , "Action"    -=> Just (string "Hide")
	       , "Condition" -=> Just (string "Installed")
	       ])

{- This is the format of what the VSI installer emits.
               , [ "Dialog_" -=> "FinishedForm"
	           "Control" -=> "Body2"
		 ]
	       , [ "Text"    -=> Just ("{\\VSI_MS_Sans_Serif13.0_0_0}" ++ str)
-}

addDestText = do
  addRow (newControl [ "Dialog_"      -=> Just (string "SetupTypeDlg")
  		     , "Control"      -=> Just (string "InstallDirLabel")
		     , "Type"         -=> Just (string "Text")
		     , "X"            -=> Just (int 105)
		     , "Y"            -=> Just (int 215)
		     , "Width"        -=> Just (int 250)
		     , "Height"       -=> Just (int 10)
		     , "Attributes"   -=> Just (int 3)
		     , "Text"         -=> Just (string "[DlgTitleFont]Install directory: [TARGETDIR]")
		     ])


addFileExtensions :: String -> [Extension] -> IM ()
addFileExtensions _ [] = return ()
addFileExtensions feat ls = do
   mapM_ addExt ls
   replaceRow ( "AdvtExecuteSequence"
              , [ ("Action" -=> "RegisterExtensionInfo")]
	      , [ ("Condition", Just (string "OptFileExt=\"Yes\""))]
	      )
   replaceRow ( "InstallExecuteSequence"
              , [ ("Action" -=> "RegisterExtensionInfo")]
	      , [ ("Condition", Just (string "OptFileExt=\"Yes\""))]
	      )
   replaceRow ( "InstallExecuteSequence"
              , [ ("Action" -=> "UnregisterExtensionInfo")]
	      , [ ("Condition", Just (string "OptFileExt=\"Yes\""))]
	      )
 where
   addExt (progID, app, icon, ext) = 
   	addExtension feat
		     progID app icon ext

addVerbs :: [Verb] -> IM ()
addVerbs ls = mapM_ addV ls
 where
   addV (ext, verb, label, args) = addVerb ext verb label args

addExtension feat progId exeFile icoFile ext = do
  addProgId progId icoFile
  dirs   <- getDirs
  comps  <- getComponents
  let cKey = findExeComponent dirs comps exeFile
  let featureKey = idToKey feat
  addRow (newExtension [ "Extension"	-=> Just (string ext)
  		       , "Component_"   -=> Just (string cKey)
		       , "ProgId_"      -=> Just (string progId)
--		       , "MIME_"        -=> Nothing
		       , "Feature_"     -=> Just (string featureKey)
		       ])
  		
addVerb ext verb command arg = do
   addRow (newVerb [ "Extension_"	-=> Just (string ext)
   		   , "Verb"		-=> Just (string verb)
		   , "Sequence"		-=> Just (int 1)
		   , "Command"		-=> Just (string command)
		   , "Argument"		-=> Just (string arg)
		   ])

-- given a progID (and its icon), create the ProgId row for it.
addProgId progID icoFile = do
  rs  <- getTableRows "ProgId"
  let vs = concatMap snd rs
      ms = filter hasProgId vs
      
      hasProgId ("ProgId", Just (String x)) = x == progID
      hasProgId _ = False

  if (not (null ms))
   then return ()
   else do
    key <- addIcon icoFile
    addRow (newProgId [ "ProgId"        -=> Just (string progID)
--  		      , "ProgId_Parent" -=> Nothing
--		      , "Class_"        -=> Nothing
--		      , "Description"   -=> Nothing
		      , "Icon_"         -=> Just (string key)
		      , "IconIndex"     -=> Just (int 0)
		      ])

configureLicense Nothing = 
    replaceRow ( "Property"
               , [ ("Property" -=> "ShowLicenseDlg")]
	       , [ ("Value", Just (string "0"))]
	       )
configureLicense (Just f) = do
 	 -- make sure the we consider displaying the  license dlg first.
{-
         -- Hmm..don't seem to do the trick; only setting the Ordering
	 -- for the dialog we're after seems to work tho.
	replaceRow ("ControlEvent",
		      [ ("Dialog_",   "WelcomeDlg")
		      , ("Control_",  "Next")
		      , ("Event",     "NewDialog")
		      , ("Argument",  "SetupTypeDlg")
		      , ("Condition", "1")
		      ],
		      [ ("Ordering",   Just (string "2"))
		      , ("Condition",  Just (string "0")) ]
		      )
-}
	replaceRow ("ControlEvent",
		      [ ("Dialog_",   "WelcomeDlg")
		      , ("Control_",  "Next")
		      , ("Event",     "NewDialog")
		      , ("Argument",  "LicenseAgreementDlg")
		      , ("Condition", "ShowLicenseDlg = 1")
		      ],
		      [ ("Ordering",   Just (string "1")) ]
		      )
	replaceRow ("Control", 
		    [ ("Dialog_", "LicenseAgreementDlg")
		    , ("Control", "AgreementText")
		    ],
		    [ ("Text", Just (file f)) ])

setURL url = 
	replaceRow ( "Property"
		   , [ ("Property" -=> "ARPHELPLINK") ]
		   , [ ("Value", Just (string url))]
		   )

setUserRegistration wantIt
 | wantIt    = return ()
 | otherwise = 
      -- turn off registration dialogue; not really used.
    replaceRow ( "Property"
               , [ ("Property" -=> "ShowUserRegistrationDlg")]
	       , [ ("Value", Just (string "0"))]
	       )


addBannerBitmap nm Nothing     = return ()
addBannerBitmap nm (Just bmap) = do
  addBinary nm bmap
  replaceRow ( "Property"
             , [ ("Property" -=> "BannerBitmap")]
	     , [ ("Value", Just (string nm))]
	     )

addDialogBitmap nm Nothing     = return ()
addDialogBitmap nm (Just bmap) = do
  addBinary nm bmap
  replaceRow ( "Property"
             , [ ("Property" -=> "DialogBitmap")]
	     , [ ("Value", Just (string nm))]
	     )

addBinary nm bmap = 
  addRow (newBinary [ "Name"  -=> Just (string nm)
  		    , "Data"  -=> Just (file bmap)
		    ])

addNestedInstalls ss = zipWithM_ addInst ss [0..]
 where
  addInst (msiFile, mbOpts) idx = do
    -- Note: this has to come after InstallFinalize (6600)
   let seqNo = 6601+idx
   addRow (newCustomAction
	      ([ "Action"    -=> Just (string ("RUN_NESTED_"++show idx))
	       , "Type"      -=> Just (int 7) -- see MSI SDK custom action type list.
	       , "Source"    -=> Just (string msiFile)] ++
	        case mbOpts of
	         Nothing -> []
	         Just x  -> [ "Target" -=> Just (string x) ]))
   mapM_ (\ act -> addRow (act
			     [ "Action"    -=> Just (string ("RUN_NESTED_" ++ show idx))
			     , "Condition" -=> Just (string "1")
			     , "Sequence"  -=> Just (int seqNo)
			     ]))
	 [ newAdminExecuteSequence
	 , newInstallExecuteSequence
	 ]