bamse-0.9.1: Bamse/PackageGen.hs
--
-- (c) 2007, Galois, Inc.
--
-- 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
]