bamse-0.9.4: Bamse/PackageGen.hs
--------------------------------------------------------------------
-- |
-- 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 Bamse.Util.Dir
--import Util.Path
import System.FilePath hiding ( addExtension )
import Bamse.Util.List
import Data.Maybe ( isJust, isNothing, fromJust )
import Data.List ( inits )
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)
addAssemblies (p_baseFeature pkg_data) (p_assemblies 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)
mapM_ (writeDialog 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_cabalPackage pkg_data)
addServices (p_services pkg_data)
maybe (return ())
(\ cp -> do
addDirOrFile pkg_data False (toolDir (p_ienv pkg_data) </> "tools" </> "custWrap.exe")
setupCabalPackage cp)
(p_cabalPackage pkg_data)
{-
when (isJust (p_ghcPackage pkg_data))
(setupGhcPackage (fromJust (p_ghcPackage pkg_data)))
-}
addNestedInstalls (p_nestedInstalls pkg_data)
where
ienv = p_ienv pkg_data
addServices :: [Service] -> IM ()
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 (takeExtension (serv_binary s)) = replaceExtension (serv_binary s) "exe"
| 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.
tKey <- newId >>= return.idToKey
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 :: Maybe CabalPackage -> IM ()
addRegSearch ghcPackage
| isNothing ghcPackage = return ()
| otherwise = do
let pkg = fromJust ghcPackage
installDirKey <- newId >>= return.idToKey
ghcPkgDirKey <- newId >>= return.idToKey
gId <- newId
let ghcPkgKey = idToKey gId
{-
addRow (newSignature [ "Signature" -=> Just (string installDirKey)
, "FileName" -=> Just (string "README.txt")
])
-}
addRow (newSignature [ "Signature" -=> Just (string ghcPkgKey)
, "FileName" -=> Just (string "runghc.exe")
])
{-
addRow (newSignature [ "Signature" -=> Just (string ghcPkgDirKey)
, "FileName" -=> Just (string "bin")
])
-}
addRow (newAppSearch [ "Property" -=> Just (string "GHCPKG")
, "Signature_" -=> Just (string ghcPkgKey)
])
addRow (newAppSearch [ "Property" -=> Just (string "GHCPKGDIR")
, "Signature_" -=> Just (string ghcPkgDirKey)
])
addRow (newAppSearch [ "Property" -=> Just (string "InstallDir")
, "Signature_" -=> Just (string installDirKey)
])
addRow (newRegLocator [ "Signature_" -=> Just (string installDirKey)
, "Root" -=> Just (int 1) -- 1=HKCU; 2=HKLM
, "Key" -=> Just (string ("Software\\Haskell\\GHC\\ghc-"++ cabal_forGhcVersion pkg))
, "Name" -=> Just (string "InstallDir")
, "Type" -=> Just (int 0) -- 'Key' is a directory.
])
addRow (newDrLocator [ "Signature_" -=> Just (string ghcPkgDirKey)
, "Parent" -=> Just (string installDirKey)
, "Path" -=> Just (string "bin")
, "Depth" -=> Just (int 1)
])
addRow (newDrLocator [ "Signature_" -=> Just (string ghcPkgKey)
, "Parent" -=> Just (string ghcPkgDirKey)
, "Path" -=> Just (string "")
, "Depth" -=> Just (int 0)
])
--
-- 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 ()
Bamse.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 fPath0 = do
-- The 'controlling' directory of the file/dir.
-- For a file, the parent dir; for a directory, itself.
let dName
| isDir = normalise (dropTrailingPathSeparator fPath)
| otherwise = normalise (takeDirectory 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 (takeDirectory sDir) dName
createDirPath (p_verbose pkg) "TARGETDIR" (splitPath2 dNameRel)
let
parentDir ds =
case lookupDirectory dNameRel ds of
Just x -> x
_ -> "TARGETDIR"
dirKey <- getDirs >>= return.parentDir
when (null (shortLong (takeFileName dName)))
(ioToIM (putStrLn ("empty: "++ show (dName, takeFileName dName))))
if not isSpecialFile
then do
comps <- getComponents
case mbFindDirComponent dirKey comps of
Just x -> return x
Nothing -> do
ioToIM (putStrLn ("INTERNAL ERROR: Component missing directory mapping: "++show (dName,sDir,dNameRel,dirKey)))
return "TARGETDIR"
else 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
-- ..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 (takeFileName fPath)) (show fsz))
where
fPath = normalise fPath0
isSpecialFile = isCompWorthy fPath
-- Files with certain file extensions get put into sep. components.
-- See 'addDirOrFile' comments as to why this is done.
isCompWorthy fpath = takeExtension fpath `elem` [".exe", ".dll", ".ocx", ".hlp"]
splitPath2 :: FilePath -> [FilePath]
splitPath2 xs = map joinPath $ tail $ inits $ splitDirectories xs
-- 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 (takeFileName 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 fs0 = do
let fs
| null fs0 = [Leaf bFeat]
| otherwise = fs0
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 _ (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@(i,_) feats -> do
addFeature parent lab p
zipWithM_ (\ f u -> addFeatureTree (Just (idToKey i)) f (lab*10+u))
feats
[(1::Int),3..]
addFeature mbParent v (featName, featDesc) = do
let featKey = idToKey featName
addRow (newFeature
(("Feature" -=> Just (string featKey)) :
(case mbParent of
Just fp -> (("Feature_Parent" -=> Just (string fp)):)
_ -> 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 :: [(FilePath, String)] -> [(FilePath,String)] -> FilePath -> FilePath
findExeComponent dirs comps fpath =
-- be a bit flexible here & allow basename of the
-- app targets to be used.
let dirs' = dirs ++ mapFst takeFileName 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 :: String -> [(String, String)] -> String
findDirComponent dir comps =
case mbFindDirComponent dir comps of
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 :: String -> [(String, String)] -> Maybe String
mbFindDirComponent dir comps = lookup dir (map swap comps)
swap :: (a,b) -> (b,a)
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 hkey 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 hkey)
, "Name" -=> fmap string nm
, "Component_" -=> Just (string cKey)
])
_ ->
addRow (newRegistry
[ "Registry" -=> Just (string rKey)
, "Root" -=> Just (string (toHiveId hive))
, "Key" -=> Just (string hkey)
, "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 _ [] = error "createDirs: empty list; unexpected.."
createDirs pKey [d] = do
appKey <- newId >>= return.idToKey
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 :: IM ()
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 :: InstallEnv -> Id -> Shortcut -> IM (String, Shortcut)
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 'takeFileName' of the srcDir,
-- so pin this in front of the user-specified directory.
let bdir = takeFileName (srcDir ienv)
let tgt = scut_target s
let tdir
| null tgt = bdir
| otherwise = normalise (bdir </> tgt)
-- Note: no need to put a slash between the two (indeed, it's harmful.)
let odir = "[TARGETDIR]" ++ tgt
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 tExe = findExeComponent dirs comps (scut_target s) in
if tExe == (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,_) -> (takeFileName x, st)) ls
case lookup tExe ls' of
Nothing -> do
ioToIM (putStrLn ("WARNING: unable to locate target " ++ show tExe))
return (featureKey, s)
Just (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=tExe})
where
featureKey = idToKey feat
addShortcut :: Key -> (String,Shortcut) -> IM ()
addShortcut appKey (featureKey,s) = do
sKey <- newId >>= return.idToKey
(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 sKey)
, "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 iKey = take 7 (idToKey i) ++ ".exe"
addRow (newIcon [ "Name" -=> Just (string iKey)
, "Data" -=> Just (file icoFile)
])
return iKey
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 :: Maybe String -> IM ()
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 :: IM ()
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 :: Id
-> String
-> FilePath
-> String
-> String
-> IM ()
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 :: String -> String -> String -> String -> IM ()
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 :: String -> String -> IM ()
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
k <- addIcon icoFile
addRow (newProgId [ "ProgId" -=> Just (string progID)
-- , "ProgId_Parent" -=> Nothing
-- , "Class_" -=> Nothing
-- , "Description" -=> Nothing
, "Icon_" -=> Just (string k)
, "IconIndex" -=> Just (int 0)
])
configureLicense :: Maybe FilePath -> IM ()
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 :: String -> IM ()
setURL "" = return ()
setURL url =
replaceRow ( "Property"
, [ ("Property" -=> "ARPHELPLINK") ]
, [ ("Value", Just (string url))]
)
setUserRegistration :: Bool -> IM ()
setUserRegistration wantIt
| wantIt = return ()
| otherwise =
-- turn off registration dialogue; not really used.
replaceRow ( "Property"
, [ ("Property" -=> "ShowUserRegistrationDlg")]
, [ ("Value", Just (string "0"))]
)
addBannerBitmap :: String -> Maybe FilePath -> IM ()
addBannerBitmap _ Nothing = return ()
addBannerBitmap nm (Just bmap) = do
addBinary nm bmap
replaceRow ( "Property"
, [ ("Property" -=> "BannerBitmap")]
, [ ("Value", Just (string nm))]
)
addDialogBitmap :: String -> Maybe FilePath -> IM ()
addDialogBitmap _ Nothing = return ()
addDialogBitmap nm (Just bmap) = do
addBinary nm bmap
replaceRow ( "Property"
, [ ("Property" -=> "DialogBitmap")]
, [ ("Value", Just (string nm))]
)
addBinary :: String -> FilePath -> IM ()
addBinary nm bmap =
addRow (newBinary [ "Name" -=> Just (string nm)
, "Data" -=> Just (file bmap)
])
addNestedInstalls :: [(String,Maybe String)] -> IM ()
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
]
addAssemblies :: Feature -> [Assembly] -> IM ()
addAssemblies feat as = mapM_ (addAssembly feat) as
addAssembly :: Feature -> Assembly -> IM ()
addAssembly bFeat a = do
let featKey = idToKey (fst bFeat)
dirs <- getDirs
comps <- getComponents
let cKey = findExeComponent dirs comps (assem_dll a)
aKey <- maybe (return Nothing) (\ x -> findExeFile x >>= return.Just) (assem_manifest a)
addRow (newMsiAssembly
([ "Component_" -=> Just (string cKey)
, "Feature_" -=> Just (string featKey)
, "File_Manifest" -=> fmap string aKey
, "File_Application" -=> fmap string (assem_privatePath a)
, "Attributes" -=> if assem_win32 a then Just (int 1) else Just (int 0)
]))
let
vs_win32
| not (assem_win32 a) = [ ("ProcessorArchitecture", "MSIL")]
| otherwise =
[ ("Type", "win32")
, ("ProcessorArchitecture", "x86") -- are there any others? ;-)
]
vs =
[ ("Name", assem_name a)
, ("Version", assem_version a)
, ("Culture", (\ x -> if null x then "neutral" else x) $ assem_culture a)
, ("PublicKeyToken", assem_publicKey a)
] ++ vs_win32
mapM_ (\ (n,v) ->
addRow (newMsiAssemblyName
[ "Component_" -=> Just (string cKey)
, "Name" -=> Just (string n)
, "Value" -=> Just (string v)
]))
vs