bamse (empty) → 0.9.1
raw patch · 78 files changed
+12207/−0 lines, 78 filesdep +basedep +comdep +directorysetup-changedbinary-added
Dependencies added: base, com, directory, haskell98, pretty
Files
- Bamse/Builder.hs +115/−0
- Bamse/DiaWriter.hs +344/−0
- Bamse/Dialog.hs +217/−0
- Bamse/DialogUtils.hs +257/−0
- Bamse/GhcPackage.hs +19/−0
- Bamse/IMonad.hs +139/−0
- Bamse/MSIExtra.hs +75/−0
- Bamse/MSITable.hs +2029/−0
- Bamse/Options.hs +223/−0
- Bamse/Package.hs +192/−0
- Bamse/PackageGen.hs +932/−0
- Bamse/PackageUtils.hs +142/−0
- Bamse/WindowsInstaller.hs +1817/−0
- Bamse/Writer.hs +702/−0
- LICENSE +29/−0
- Main.hs +64/−0
- README +3/−0
- Setup.hs +8/−0
- System/Path.hs +45/−0
- Util/Dir.hs +120/−0
- Util/GetOpts.hs +206/−0
- Util/List.hs +97/−0
- Util/Path.hs +256/−0
- art/README.txt +9/−0
- art/banner.bmp binary
- art/banner2.bmp binary
- art/banner3.bmp binary
- art/bground.bmp binary
- art/bground2.bmp binary
- art/dlgbmp3rd.bmp binary
- art/galois-bground-fade.jpg binary
- art/galois-bground.JPG binary
- art/ghc-background-3rd.bmp binary
- art/ghc-background.bmp binary
- art/haskell-background.bmp binary
- art/haskell-banner.bmp binary
- bamse.cabal +111/−0
- data/license.rtf binary
- data/msi/Schema.msi binary
- data/msi/Sequence.msi binary
- data/msi/UISample.msi binary
- data/msi/base.msi binary
- doc/errors.txt +23/−0
- doc/howto.html +64/−0
- doc/howto.txt +41/−0
- doc/icons.txt +33/−0
- doc/index.html +77/−0
- doc/using.html +590/−0
- doc/using.txt +515/−0
- icons/cmdIcon.exe binary
- icons/folder.exe binary
- icons/hs.exe binary
- icons/hsx.exe binary
- icons/html.exe binary
- icons/html2.exe binary
- icons/pdf.exe binary
- icons/star.exe binary
- icons/txt.exe binary
- license.rtf binary
- templates/Alex.hs +129/−0
- templates/Bamse.hs +167/−0
- templates/Base.hs +122/−0
- templates/ComPkg.hs +157/−0
- templates/Cryptol.hs +260/−0
- templates/GHC.hs +165/−0
- templates/GaloisPkg.hs +151/−0
- templates/Greencard.hs +131/−0
- templates/HDirectLib.hs +107/−0
- templates/Haddock.hs +129/−0
- templates/Happy.hs +129/−0
- templates/Hugs98.hs +227/−0
- templates/Hugs98Net.hs +147/−0
- templates/PubCryptol.hs +250/−0
- templates/SOE.hs +108/−0
- tools/Makefile +11/−0
- tools/README.txt +10/−0
- tools/msiIcon.c +252/−0
- tools/msiIcon.h +61/−0
+ Bamse/Builder.hs view
@@ -0,0 +1,115 @@+--+-- (c) 2007, Galois, Inc.+--+-- Toplevel module for bamse library/app.+-- +-- Bamse - a batch MSI installer creator.+--+-- ToDo:+-- - ability to organise installed bits into features/sub parts.+-- +module Bamse.Builder ( genBuilder ) where++import Bamse.Package+import Bamse.Writer+import Bamse.IMonad+import Bamse.PackageGen+import Bamse.MSIExtra+import Bamse.PackageUtils+import Bamse.DialogUtils++import System.Win32.Com ( coRun )+import IO+import Util.Path ( dirname, appendSep, toPlatformPath, joinPath, splitPath, appendPath )+import Util.Dir+import Util.List ( ifCons )++import System +import IO+import Monad ( when )+import Maybe+import Bamse.Options+import System.Directory++genBuilder :: PackageData -> IO ()+genBuilder pkg = do+ putStrLn ("Installer builder for: " ++ name (p_pkgInfo pkg)) >> hFlush stdout+ opts <- getOptions (p_defOutFile pkg)+ ds <- (p_fileMap pkg) (opt_ienv opts)+ (dsDist, ienv) <- mkDistTree (opt_ienv opts) (srcDir $ opt_ienv opts)+ (name $ p_pkgInfo pkg) (p_distFileMap pkg)+ ds+ let pkg' = pkg{ p_files = dsDist+ , p_dialogs = + (if p_userInstall pkg+ then (setupTypeDialog:)+ else if isJust (p_ghcPackage pkg)+ then (ghcPkgDialog:)+ else id) $+ -- add customization selection dialog only if the+ -- builder supplies the relevant features.+ case options (opt_ienv opts) of+ [] -> []+ os -> [customizeDialog os]+ , p_productGUID = fromJust (opt_productGUID opts)+ , p_revisionGUID = fromJust (opt_revisionGUID opts)+ , p_ienv = opt_ienv opts+ , p_verbose = opt_verbose opts+ }+ let bamseDir = toolDir (p_ienv pkg')+ coRun $ do+ (_, ts, tabs, reps) <- doInstall [] (genTables pkg')+ let env = + WriterEnv + { w_toolDir = bamseDir+ , w_templateDir = lFile (lFile bamseDir "data") "msi"+ , w_outFile = outFile (p_ienv pkg')+ , w_srcDir = dirname (srcDir $ p_ienv pkg')+ , w_package = pkg'+ }+ outputMSI env tabs ts reps+ return ()+ where+ options ienv+ = ifCons (not (null (p_extensions pkg ienv)))+ ("Register file extensions", "OptFileExt", True) $+ ifCons (not (null (p_desktopShortcuts pkg ienv)))+ ("Create desktop shortcuts", "OptDesktopShortcuts", True) $+ ifCons (not (null (snd $ p_startMenu pkg ienv)))+ ("Create start menu folder", "OptStartMenu", True)+ []+++mkDistTree :: InstallEnv+ -> FilePath+ -> String+ -> Maybe (FilePath -> Maybe FilePath)+ -> DirTree+ -> IO (DirTree, InstallEnv)+mkDistTree ienv _ _ Nothing ds = return (ds, ienv)+mkDistTree ienv topDir nm (Just fn) ds = do+ -- copy over directory tree into temporary 'outDir'+ fp <- getCurrentDirectory+ catch (createDirectory (appendP fp "out")) (\ _ -> return ())+ let outDir = appendP fp (appendP "out" nm)+ catch (createDirectory outDir) (\ _ -> return ())+ copyOver outDir ds+ ds <- allFiles outDir+ return (ds, ienv{srcDir=outDir})+ where+ copyOver _ Empty = return ()+ copyOver outDir (File f) = do+ case fn f of+ Nothing -> return ()+ Just f -> do+ let cmd = ("copy /b \"" ++ f ++ "\" \"" ++ + appendP outDir (dropDirPrefix topDir f) ++ "\" > nul")+ system cmd+ return ()+ copyOver outDir (Directory fp subs) = do+ case fn fp of+ Nothing -> return ()+ Just fp -> system ("mkdir " ++ appendP outDir (dropDirPrefix topDir fp)) >> return ()+ mapM_ (copyOver outDir) subs++ appendP a b = toPlatformPath $ appendPath a b
+ Bamse/DiaWriter.hs view
@@ -0,0 +1,344 @@+--+-- (c) 2007, Galois, Inc.+--+-- Converting an MSI dialog from a Dialog type.+--+module Bamse.DiaWriter where++import Bamse.Dialog+import Bamse.MSITable+import Bamse.IMonad+import Bamse.Package++import Control.Monad+import Data.Int+import Data.Bits+import Data.Maybe++writeDialog :: PackageData -> Maybe GhcPackage -> Bool -> Dialog -> IM ()+writeDialog pkg ghcPackage hasLicense+ (Dialog diaName cs conds evs+ (hc,vc) (w,h) attrs+ title first def cancel+ afterDlg afterDlgCond props) = do+ addRow (newDialog [ "Dialog" -=> Just (string diaName)+ , "HCentering" -=> Just (int hc)+ , "VCentering" -=> Just (int vc)+ , "Width" -=> Just (int w)+ , "Height" -=> Just (int h)+ , "Attributes" -=> Just (int (flattenAttrib attrs))+ , "Title" -=> Just (string title)+ , "Control_First" -=> Just (string first)+ , "Control_Default" -=> Just (string def)+ , "Control_Cancel" -=> Just (string cancel)+ ])+ mapM_ (addControlEvent diaName) evs+ mapM_ (addControl diaName) cs+ mapM_ (addControlCondition diaName) conds+ -- have 'after dialog's Next button spawn this dialog..+ let (afterDlg', afterDlgCond') = + case afterDlg of+ "WelcomeDlg" + | hasLicense -> ("LicenseAgreementDlg", "IAgree = \"Yes\" AND ShowLicenseDlg = 1")+ | otherwise -> (afterDlg, afterDlgCond)+ "SetupKindDialog"+ | hasLicense -> ("LicenseAgreementDlg", "IAgree = \"Yes\" AND ShowLicenseDlg = 1")+ | otherwise -> (afterDlg, afterDlgCond)+ "CustomizeDlg" -> (afterDlg, afterDlgCond)+ + addRow (newControlEvent [ "Dialog_" -=> Just (string afterDlg') -- "WelcomeDlg")+ , "Control_" -=> Just (string "Next")+ , "Event" -=> Just (string "NewDialog")+ , "Argument" -=> Just (string diaName)+ , "Condition" -=> Just (string afterDlgCond') -- "NOT Installed")+ , "Ordering" -=> Just (string "3")+ ])+ -- and our Back button point to the 'after dialog'.+ addRow (newControlEvent [ "Dialog_" -=> Just (string diaName)+ , "Control_" -=> Just (string "Back")+ , "Event" -=> Just (string "NewDialog")+ , "Argument" -=> Just (string afterDlg)+ , "Condition" -=> Just (string "1")+ ])+ -- Our Next button will invoke the dialog that+ -- used to follow (ditto for its Back button.)+ let nextDlg+ = case afterDlg of+ "WelcomeDlg" -> "SetupTypeDlg"+ "SetupKindDialog" -> "SetupTypeDlg"+ "CustomizeDlg" -> "VerifyReadyDlg"+ _ -> error ("unknown/unsupported dialog: " ++ afterDlg)+ addRow (newControlEvent ([ "Dialog_" -=> Just (string diaName)+ , "Control_" -=> Just (string "Next")+ , "Event" -=> Just (string "NewDialog")+ , "Argument" -=> Just (string nextDlg)+ , "Condition" -=> Just (string "1") -- "NOT Installed"+ ]))+ ioToIM (print (nextDlg,diaName))+ addRow (newControlEvent [ "Dialog_" -=> Just (string nextDlg) -- "SetupTypeDlg"+ , "Control_" -=> Just (string "Back")+ , "Event" -=> Just (string "NewDialog")+ , "Argument" -=> Just (string diaName)+ , "Condition" -=> Just (string afterDlgCond') -- "NOT Installed"+ ])+ mapM_ + (\ (p,v) -> addRow (newProperty [ "Property" -=> Just (string p)+ , "Value" -=> Just (string v)+ ]))+ props++setupGhcPackage :: GhcPackage -> IM ()+setupGhcPackage pkg = do+ let pkg_file = fromMaybe "package.pkg" (ghc_packageFile pkg)+ addRow (newCustomAction+ [ "Action" -=> Just (string "UNINSTALL_GHC_PKG")+ -- ignore errors+ , "Type" -=> Just (int (50+64))+ , "Source" -=> Just (string "GHCPKGDIR")+ , "Target" -=> Just (string ("-r " ++ ghc_packageName pkg))+ ])+ mapM_ (\ act -> + addRow (act [ "Action" -=> Just (string "INSTALLGHCPKG")+ , "Condition" -=> Just (string ("NOT Installed AND RUNPKGMGR=1"))+ , "Sequence" -=> Just (int 6601)+ ]))+ [ newAdminExecuteSequence+ , newInstallExecuteSequence+ ]+ mapM_ (\ act -> + addRow (act [ "Action" -=> Just (string "UNINSTALL_GHC_PKG")+ , "Condition" -=> Just (string "REMOVE")+ , "Sequence" -=> Just (int 6602)+ ]))+ [ newAdminExecuteSequence+ , newInstallExecuteSequence+ ]+ let opts = + "-DTARGETDIR=\"[TARGETDIR]\\\"" +++ case ghc_pkgCmdLine pkg of+ Nothing -> []+ Just v -> ' ':v+ addRow (newCustomAction+ [ "Action" -=> Just (string "INSTALLGHCPKG")+ , "Type" -=> Just (int 50)+ , "Source" -=> Just (string "GHCPKGDIR")+ , "Target" -=> Just (string ("-u -i \"[TARGETDIR]"++pkg_file++"\" " ++ opts))+ ])++addControl diaName (Control name ty pName + (x,y) (w,h)+ text as next help) = do+ addRow (newControl [ "Dialog_" -=> Just (string diaName)+ , "Control" -=> Just (string name)+ , "Type" -=> Just (string $ toControlTypeString ty)+ , "X" -=> Just (int x)+ , "Y" -=> Just (int y)+ , "Width" -=> Just (int width)+ , "Height" -=> Just (int height)+ , "Attributes" -=> Just (int $ flattenAttrib as)+ , "Property" -=> fmap string pName+ , "Text" -=> mbString text+ , "Control_Next" -=> mbString next+ , "Help" -=> mbString help+ ])+ case ty of+ RadioButtonGroup chs -> do+ zipWithM_ addRadioButton [(1::Int)..] chs+ return ()+ CheckBox onYes -> addCheckBox onYes+ _ -> return ()++ where+ flattenAttrib as = fromIntegral (foldr marshal (0::Int32) as)+ + addCheckBox onYes = do+ addRow (newCheckBox [ "Property" -=> fmap string pName+ , "Value" -=> Just (string onYes)+ ])+ + width = w+ height = + case ty of+ RadioButtonGroup chs -> 20 * length chs+ _ -> h++ addRadioButton idx (RadioButton txt colStr) = + addRow (newRadioButton + [ "Property" -=> fmap string pName+ , "Order" -=> Just (int idx)+ , "Value" -=> Just (string colStr)+ , "X" -=> Just (int 5)+ , "Y" -=> Just (int ((idx-1)*20))+ , "Width" -=> Just (int 250)+ , "Height" -=> Just (int 15)+ , "Text" -=> Just (string txt)+ ])++ marshal x acc = acc .|.+ case x of+ Visible -> 0x01+ Enabled -> 0x02+ Sunken -> 0x04+ Indirect -> 0x08+ IntegerControl -> 0x10+ RightToLeftReadingOrder -> 0x20+ RightAligned -> 0x40+ LeftScroll -> 0x80+ BiDi -> 0xE0+ -- text control attributes+ Transparent -> 0x00010000+ NoPrefix -> 0x00020000+ NoWrap -> 0x00040000+ FormatSize -> 0x00080000+ UserLanguage -> 0x00100000+ -- edit control+ MultiLine -> 0x00010000+ Password -> 0x00200000+ -- progress bar+ Progress95 -> 0x00010000+ -- volume and directory select combo controls + RemovableVolume -> 0x00010000+ FixedVolume -> 0x00020000+ RemoteVolume -> 0x00040000+ CDRomVolume -> 0x00080000+ RAMDiskVolume -> 0x00100000+ FloppyVolume -> 0x00200000+ -- volume cost list attrs+ ShowRollback -> 0x00400000+ -- list box and combo box controls attributes+ Sorted -> 0x00010000+ ComboList -> 0x00020000+ -- picture button control attributes+ ImageHandle -> 0x00010000+ PushLike -> 0x00020000+ BitmapAttr -> 0x00040000+ Icon -> 0x00080000+ FixedSize -> 0x00100000+ IconSize16 -> 0x00200000+ IconSize32 -> 0x00400000+ IconSize48 -> 0x00600000+ -- radio button group attributes+ HasBorder -> 0x01000000+ _ -> 0x0+ +{-+ BillboardName String+ IndirectPropertyName Label+ ProgressControl Int Int String+ PropertyName Label+ PropertyValue Label+ TextControl String+ TimeRemaining Int+-} ++ toControlTypeString x = + case x of+ PushButton{} -> "PushButton"+ PathEdit -> "PathEdit"+ Line{} -> "Line"+ Text{} -> "Text"+ ScrollableText{} -> "ScrollableText"+ Bitmap{} -> "Bitmap"+ RadioButtonGroup{} -> "RadioButtonGroup"+ CheckBox{} -> "CheckBox"+ _ -> error ("toControlTypeString: unhandled control ")++mbString :: String -> Maybe ColumnValue+mbString "" = Nothing+mbString x = Just (string x)++addControlEvent diaName (control, ev, cond, ordering) = + addRow (newControlEvent [ "Dialog_" -=> Just (string diaName)+ , "Control_" -=> Just (string control)+ , "Event" -=> Just (string (toEventString ev))+ , "Argument" -=> toEventArg ev+ , "Condition" -=> mbString cond+ , "Ordering" -=> mbString ordering+ ])++addControlCondition diaName (cName, action, cond) =+ addRow (newControlCondition [ "Dialog_" -=> Just (string diaName)+ , "Control_" -=> Just (string cName)+ , "Action" -=> Just (string action)+ , "Condition" -=> Just (string cond)+ ])++toEventString :: ControlEvent -> String+toEventString x = + case x of + SetProperty p v -> '[':p ++ "]"+ ActionData -> "ActionData"+ ActionText -> "ActionText"+ AddLocal f -> "AddLocal"+ AddSource f -> "AddSource"+ CheckExistingTargetPath p -> "CheckExistingTargetPath"+ CheckTargetPath p -> "CheckTargetPath"+ DirectoryListNew -> "DirectoryListNew"+ DirectoryListOpen -> "DirectoryListOpen"+ DirectoryListUp -> "DirectoryListUp"+ DoAction a -> "DoAction"+ EnableRollback v -> "EnableRollback"+ EndDialog d -> "EndDialog"+ IgnoreChange -> "IgnoreChange"+ NewDialog d -> "NewDialog"+ Reinstall f -> "Reinstall"+ ReinstallMode f -> "ReinstallMode"+ Remove f -> "Remove"+ Reset -> "Reset"+ ScriptInProgress -> "ScriptInProgress"+ SelectionAction -> "SelectionAction"+ SelectionBrowse -> "SelectionBrowse"+ SelectionDescription -> "SelectionDescription"+ SelectionIcon -> "SelectionIcon"+ SelectionNoItems -> "SelectionNoItems"+ SelectionPath -> "SelectionPath"+ SelectionPathOn -> "SelectionPathOn"+ SelectionSize -> "SelectionSize"+ SetInstallLevel i -> "SetInstallLevel"+ SetProgress -> "SetProgress"+ SetTargetPath p -> "SetTargetPath"+ SpawnDialog d -> "SpawnDialog"+ SpawnWaitDialog d -> "SpawnWaitDialog"+ TimeRemaining -> "TimeRemaining"+ ValidateProductID -> "ValidateProductID"++toEventArg :: ControlEvent -> Maybe ColumnValue+toEventArg x =+ case x of+ SetProperty _ "" -> Just (string "{}")+ SetProperty _ x -> Just (string x)+ AddLocal f -> Just (string f)+ AddSource f -> Just (string f)+ CheckExistingTargetPath p -> Just (string p)+ CheckTargetPath p -> Just (string p)+ DoAction a -> Just (string a)+ EnableRollback x -> Just (string x)+ EndDialog d -> Just (string d)+ NewDialog d -> Just (string d)+ Reinstall f -> Just (string f)+ ReinstallMode f -> Just (string f)+ Remove f -> Just (string f)+ SetInstallLevel i -> Just (string (show i))+ SetTargetPath p -> Just (string p)+ SpawnDialog d -> Just (string d)+ SpawnWaitDialog d -> Just (string d)+ _ -> Nothing++flattenAttrib :: [DiaAttribute] -> Int+flattenAttrib as = fromIntegral (foldr marshal (0::Int32) as)+ where+ marshal x acc = + acc .|.+ case x of + DialogVisible -> 0x1+ DialogModal -> 0x2+ DialogMinimize -> 0x4+ DialogSysModal -> 0x8+ DialogKeepModeless -> 0x10+ DialogTrackDiskSpace -> 0x20+ DialogUseCustomPalette -> 0x40+ DialogRightToLeftOrdering -> 0x80+ DialogRightAligned -> 0x100+ DialogLeftScroll -> 0x200+ DialogBiDi -> 0x380+ DialogError -> 0x10000
+ Bamse/Dialog.hs view
@@ -0,0 +1,217 @@+--+-- (c) 2007, Galois, Inc.+--+-- Low-level representation of MSI dialogs; combines together +-- the information stored in the Control, ControlCondition,+-- ControlEvent, and Dialog tables.+--+module Bamse.Dialog where++data Dialog+ = Dialog {+ dia_name :: DialogName, + -- ^ The dialog name; must be unique within an installer.+ dia_ctrls :: [Control], + -- ^ The list of controls implicitly define the 'next'+ -- focussing relationship between controls in a dialog.+ dia_conds :: [CCondition],+ dia_events :: [CEvent],+ dia_pos :: Centering,+ dia_size :: Size,+ dia_attrs :: [DiaAttribute],+ dia_title :: String,+ dia_first :: ControlName, -- id of 'first' control+ dia_def :: ControlName, -- id of 'default' control+ dia_cancel :: ControlName, -- id of 'cancel' control+ dia_after :: DialogName, -- what dialog to insert this one after...+ dia_cond :: String, -- ..under these conditions.+ dia_props :: [(PropertyName, String)]+ -- ^ properties and initial values that are used by this+ -- dialog.+ }++type Centering = (Int,Int)+type Size = (Int,Int)+type Pos = (Int,Int)++type DialogName = String+type PropertyName = String+type ControlName = String++data Control+ = Control + { -- control name.+ ctrl_name :: ControlName + -- what kind of control (along with control specific config.)+ , ctrl_type :: ControlType+ -- the property name that holds the control's value.+ , ctrl_prop :: Maybe PropertyName+ -- position and size (size in 'dialog/installer' units.)+ , ctrl_pos :: Pos+ , ctrl_size :: Size+ -- initial text+ , ctrl_text :: String + , ctrl_attrs :: [Attribute]+ , ctrl_next :: ControlName+ , ctrl_help :: String+ }++{-+ Re: Billboard -- + displays (property-less) controls that can be dynamically added+ and removed from the billboard during the install; often used+ to show progress messages etc. The addition or removal of billboard+ controls is controlled via the EventMapping table and the association+ of controls to a billboard is done via the BBControl table.+-}+++-- the type of control; whether or not the control+-- has an associated property attached to it is +data ControlType+ = Billboard String+ | Bitmap String+ | CheckBox String -- w/property; arg is what to set property when checkbox is selected.+ | ComboBox -- w/property+ | DirectoryCombo -- w/property+ | DirectoryList -- w/property+ | EditField -- w/property+ | GroupBox+ | IconControl+ | Line Size+ | ListBox -- w/property+ | ListView -- w/property+ | MaskedEdit -- w/property+ | PathEdit -- w/property+ | ProgressBar -- w/property+ | PushButton String+ | RadioButtonGroup [RadioButton] -- w/property+ | ScrollableText String+ | Text String+ | VolumeCostList+ | VolumeSelectCombo -- w/property++data RadioButton+ = RadioButton + String -- text+ String -- property value++data Attribute+ = Enabled + | Indirect+ | IntegerControl+ | LeftScroll+ | BiDi+ | RightAligned+ | RightToLeftReadingOrder+ | Sunken+ | Visible+ -- text control attributes+ | FormatSize+ | NoPrefix+ | NoWrap+ | Password+ | Transparent+ | UserLanguage+ -- progress bar+ | Progress95+ -- volume and directory select combo controls + | CDRomVolume+ | FixedVolume+ | FloppyVolume+ | RAMDiskVolume+ | RemoteVolume+ | RemovableVolume+ -- list box and combo box controls attributes+ | ComboList+ | Sorted+ -- edit control+ | MultiLine+ -- picture button control attributes+ | BitmapAttr+ | FixedSize+ | Icon+ | IconSize16+ | IconSize32+ | IconSize48+ | ImageHandle+ | PushLike+ -- radio button group attributes+ | HasBorder+ -- volume cost list attrs+ | ShowRollback+ +{-+ | BillboardName String+ | IndirectPropertyName Label+ | ProgressControl Int Int String+ | PropertyName Label+ | PropertyValue Label+ | TextControl String+ | TimeRemaining Int+-}++type CCondition + = ( ControlName -- name of control+ , String -- action+ , String -- the condition, ought to be Expr, really.+ )++type CEvent+ = ( ControlName -- name of control+ , ControlEvent -- the event+ , String -- condition+ , String -- ordering value/tag.+ )++data ControlEvent+ = SetProperty String String+ | ActionData + | ActionText+ | AddLocal String -- feature name+ | AddSource String -- feature name+ | CheckExistingTargetPath PropertyName+ | CheckTargetPath PropertyName+ | DirectoryListNew + | DirectoryListOpen + | DirectoryListUp+ | DoAction String+ | EnableRollback String+ | EndDialog String -- one of Exit, Retry, Ignore, Return.+ | IgnoreChange+ | NewDialog String -- dialog name+ | Reinstall String -- feature name (incl "ALL")+ | ReinstallMode String+ | Remove String -- feature name+ | Reset+ | ScriptInProgress + | SelectionAction+ | SelectionBrowse+ | SelectionDescription+ | SelectionIcon+ | SelectionNoItems+ | SelectionPath+ | SelectionPathOn+ | SelectionSize+ | SetInstallLevel Int+ | SetProgress+ | SetTargetPath PropertyName+ | SpawnDialog String -- dialog name+ | SpawnWaitDialog String -- dialog name + | TimeRemaining+ | ValidateProductID++data DiaAttribute+ = DialogVisible+ | DialogModal+ | DialogMinimize+ | DialogSysModal+ | DialogKeepModeless+ | DialogTrackDiskSpace+ | DialogUseCustomPalette+ | DialogRightToLeftOrdering+ | DialogRightAligned+ | DialogLeftScroll+ | DialogBiDi+ | DialogError+
+ Bamse/DialogUtils.hs view
@@ -0,0 +1,257 @@+--+-- (c) 2007, Galois, Inc.+--+-- MSI dialogs + utilities for creating your own.+--+module Bamse.DialogUtils + ( ghcPkgDialog -- :: Dialog+ , setupTypeDialog -- :: Dialog+ , customizeDialog -- :: Dialog+ ) where++import Bamse.Package+import Bamse.Dialog++ghcPkgDialog :: Dialog+ghcPkgDialog = + addControl (Control "Msg" (Text "foo") Nothing+ (40,180) (180,40)+ "WARNING: unable to locate ghc-pkg; automatic installation not available"+ [Transparent,Enabled]+ "" "") $+ addCond ("Msg", "Show", "GHCPKGDIR=\"\"") $+ addCond ("InstallKind", "Disable", "GHCPKGDIR=\"\"") $+ mkChoiceDialog "GhcPkgDialog"+ "Package installation"+ "{\\VerdanaBold13}Select [ProductName] package installation type"+ "The [Wizard] can automatically register the package with GHC; do you want this?"+ [ ("Yes", "1")+ , ("No", "0")+ ]+ "RUNPKGMGR"+ "WelcomeDlg"+ "NOT Installed"+ ("InstallKind", "2")+ +setupTypeDialog :: Dialog+setupTypeDialog = + -- Hack: ALLUSERS needs to be undefined in order+ -- to enable a per-user install. I've yet to be able+ -- to use the RadioButton table to clear a property,+ -- so instead an event is attached to the 'next' button+ -- which clears the property should it be set to zero.+ -- + addEvent ("Next", SetProperty "ALLUSERS" "{}", "(InstallKind = 0) AND (Version9x = \"\")", "1") $+ addEvent ("Next", SetProperty "ALLUSERS" "2", "(InstallKind = 2) AND (Version9x = \"\")", "2") $+ mkChoiceDialog "SetupKindDialog" + "Setup type"+ "{\\VerdanaBold13}Select [ProductName] installation type"+ "The [Wizard] will install [ProductName] on your computer. Please select who you want to install it for:"+ [ ("Just for me", "0")+ , ("Everyone", "2")+ ]+ "InstallKind"+ "WelcomeDlg"+ "NOT Installed"+ ("InstallKind", "2")++-- dialog for letting the user control the level of shell integration+-- to use (file extensions, start menu, desktop shortcuts.)+customizeDialog :: [(String, PropertyName, Bool)] -> Dialog+customizeDialog ls = + mkOptionsDialog "opts"+ "Customization options"+ "{\\VerdanaBold13}[ProductName] customization options"+ "Pick the shell integration features you want:"+ ls+ (map (\ (_,p,_) -> (p,"Yes")) ls)++mkOptionsDialog :: String+ -> String+ -> String+ -> String+ -> [(String, PropertyName, Bool)]+ -> [(PropertyName, String)]+ -> Dialog+mkOptionsDialog diaNm diaHeader diaTitle diaDesc opts props+ = Dialog + { dia_name = diaNm+ , dia_ctrls = controls+ , dia_conds = conditions+ , dia_events = events+ , dia_pos = (50,50)+ , dia_size = (370,270)+ , dia_attrs = [DialogVisible, DialogModal]+ , dia_title = diaHeader+ , dia_first = "Next"+ , dia_def = ""+ , dia_cancel = "cancelButton"+ , dia_after = "CustomizeDlg"+ , dia_cond = "1"+ , dia_props = props+ }+ where+ controls+ = withButtons "Bitmap"+ [ Control "Title" (Text "foo") Nothing+ (135,20) (220,60)+ diaTitle+ [Transparent, NoPrefix, Enabled, Visible]+ "" ""+ , Control "Description" (Text "foo") Nothing+ (135,70) (220,60)+ diaDesc+ [Transparent, NoPrefix, Enabled, Visible]+ "" ""+ , Control "Bitmap" (Bitmap "bitmap") Nothing+ (0,0) (125,234)+ "[DialogBitmap]" [Visible, FixedSize]+ "Back" ""+ ] ++ opt_controls+ opt_controls = + zipWith (\ (txt, prop, enabled) ypos -> + Control { ctrl_name = "cbox"++show ypos -- to make it unique.+ , ctrl_type = CheckBox "Yes"+ , ctrl_prop = Just prop+ , ctrl_pos = (150,ypos)+ , ctrl_size = (200,30) -- max X: 260.+ , ctrl_text = txt+ , ctrl_attrs = (if enabled then (Enabled:) else id)+ [Visible]+ , ctrl_next = ""+ , ctrl_help = ""+ })+ opts+ [90, (90+30) ..]++ conditions = []+ events = [ ("cancelButton", EndDialog "Exit", "1", "1")+ ]++mkChoiceDialog :: String -- dialog name+ -> String -- dialog header+ -> String -- title+ -> String -- description+ -> [(String, String)]+ -> PropertyName+ -> DialogName+ -> String+ -> (PropertyName, String)+ -> Dialog+mkChoiceDialog diaNm diaHeader diaTitle diaDesc opts + propName afterDiag afterDiagCond+ (initProp, initVal)+ = Dialog { dia_name = diaNm+ , dia_ctrls = controls+ , dia_conds = conditions+ , dia_events = events+ , dia_pos = (50,50)+ , dia_size = (370,270)+ , dia_attrs = [DialogVisible, DialogModal]+ , dia_title = diaHeader+ , dia_first = "Next"+ , dia_def = ""+ , dia_cancel = "cancelButton"+ , dia_after = afterDiag+ , dia_cond = afterDiagCond+ , dia_props = [(initProp, initVal)]+ }+ where+ controls+ = withButtons "Bitmap"+ [ Control "Title" (Text "foo") Nothing+ (125,20) (220,60)+ diaTitle+ [Transparent, NoPrefix, Enabled, Visible]+ "" ""+ , Control "Description" (Text "foo") Nothing+ (125,70) (220,60)+ diaDesc+ [Transparent, NoPrefix, Enabled, Visible]+ "" ""+ , Control "Bitmap" (Bitmap "bitmap") Nothing+ (0,0) (370,234)+ "[DialogBitmap]" [Visible]+ "Back" ""+ , Control "InstallKind"+ (RadioButtonGroup (map (\(txt,val) -> RadioButton txt val) opts))+ (Just propName)+ (130,120) (180,40) ""+ [{-Transparent,-}Enabled,Visible]+ "" ""+ ]+ conditions = []+ events = [ ("cancelButton", EndDialog "Exit", "1", "1")+ ]++addEvent ev d = d{dia_events=ev:dia_events d}+addControl ctrl d = d{dia_ctrls=ctrl:dia_ctrls d}+addCond cond d = d{dia_conds=cond:dia_conds d}++withButtons :: String -> [Control] -> [Control]+withButtons next ctrls = + ctrls ++ + [ Control "line" (Line (100,2)) Nothing + (0,234) (374,0) "Line" [Visible] "" ""+ , Control "Back" (PushButton "Back") Nothing+ (180,243) (56,17)+ "[ButtonText_Back]" [Enabled,Visible] "Next" ""+ , Control "Next" (PushButton "Next") Nothing+ (236,243) (56,17)+ "[ButtonText_Next]" [Enabled,Visible] "cancelButton" ""+ , Control "cancelButton" (PushButton "Cancel") Nothing+ (304,243) (56,17)+ "[ButtonText_Cancel]" [Enabled,Visible] next ""+ ]+++{- Old test def:+dialog = Dialog "TestDialog"+ controls+ conditions+ events+ (50,50) -- centered on the screen+ (370,270)+ [ DialogVisible+ , DialogModal+ ]+ "Setup type dialog"+ "Next"+ ""+ "cancelButton"+ where+ controls+ = withButtons "Bitmap"+ [ {-Control "pathSelect" PathEdit (Just "TARGETDIR") + (10,10) (260,18)+ "" [Enabled,Visible] "" "" -}+ Control "Title" (Text "foo") Nothing+ (35,20) (220,60)+ "{\\VerdanaBold13}Select [ProductName] installation type"+ [Transparent, NoPrefix, Enabled, Visible]+ "" ""+ , Control "Description" (Text "foo") Nothing+ (35,70) (220,60)+ "The [Wizard] will install [ProductName] on your computer. Please select the installation kind you want:"+ [Transparent, NoPrefix, Enabled, Visible]+ "" ""+ , Control "Bitmap" (Bitmap "bitmap") Nothing+ (0,0) (370,234)+ "[DialogBitmap]" [Visible]+ "Back" ""+ , Control "InstallKind"+ (RadioButtonGroup [ RadioButton "User only" "0"+ , RadioButton "Machine wide" "2"+ ])+ (Just "ALLUSERS")+ (40,120) (180,40) ""+ [{-Transparent,-}Enabled,Visible]+ "" ""+ ]+ conditions = []++ events = [ -- ("okButton", EndDialog "Return", "", "1")+ ("cancelButton", EndDialog "Exit", "", "1")+ ]+-}+
+ Bamse/GhcPackage.hs view
@@ -0,0 +1,19 @@+--+-- (c) 2007, Galois, Inc.+--+-- Specifying the contents of a GHC package.+--+module Bamse.GhcPackage where++data GhcPackage+ = GhcPackage { ghc_packageName :: String + -- ^ Name of the package; this must match the one in the .pkg file.+ , ghc_forVersion :: String+ -- ^ What version of GHC to install the package for.+ , ghc_packageFile :: Maybe FilePath+ -- ^ Dist-tree local path to .pkg file+ , ghc_pkgCmdLine :: Maybe String+ -- ^ Extra command-line options to feed 'ghc-pkg' when _installing_.+-- more to follow..+-- , ghc_stuff :: String+ }
+ Bamse/IMonad.hs view
@@ -0,0 +1,139 @@+--+-- (c) 2007, Galois, Inc.+--+-- The 'installer monad'+--+module Bamse.IMonad+ ( IM -- abstract. Instance of: Monad, Functor+ , doInstall -- :: [Table] -- custom table definitions+ -- -> IM a+ -- -> IO (a, [(TableName,[Row])], [Table])+ , ioToIM -- :: IO a -> IM a + , addRow -- :: Row -> IM ()+ , getTableRows -- :: TableName -> IM [Row]+ , replaceRow -- :: ReplaceRow -> IM ()+ , addTable -- :: Table -> IM ()+ , newId -- :: IM String+ , getComponents -- :: IM [(Id, Id)]+ , addCompMapping -- :: Id -> Id -> IM ()+ , addDirMapping -- :: Id -> Id -> IM ()+ , getDirs -- :: IM [(FilePath, Id, Id)]+ + , addFile+ , replaceFile+ , getFiles++ , Id+ ) where++import System.Win32.Com+import Bamse.MSITable+import System.IO.Unsafe ( unsafeInterleaveIO )+import Data.List++type Id = String++data IState + = IState { istate_guids :: [GUID] -- infinite supply of GUIDs.+ , istate_tables :: [Table]+ , istate_rows :: [Row]+ , istate_replaces :: [ReplaceRow]+ , istate_dirs :: [(FilePath, Id)]+ , istate_feats :: [(String{-FeatureName-}, Id)]+ , istate_comps :: [(Id, Id)]+ , istate_files :: [(FilePath, (Id, Id, String, String))]+ }++newtype IM a = IM (IState -> IO (a, IState))++instance Functor IM where+ fmap f x = x >>= \ v -> return (f v)++instance Monad IM where+ (>>=) = bindIM+ return = returnIM++bindIM :: IM a -> (a -> IM b) -> IM b+bindIM (IM a) cont = IM $ \ st -> do+ (x,st1) <- a st+ let (IM b) = cont x+ b st1++returnIM x = IM $ \ st -> return (x,st)++doInstall :: [Table] -> IM a -> IO (a, [(TableName, [Row])], [Table], [ReplaceRow])+doInstall custTables (IM ia) = do+ ls <- new_guids+ let initial_state = + IState { istate_guids = ls+ , istate_tables = (custTables ++ msiTables)+ , istate_rows = []+ , istate_replaces = []+ , istate_dirs = []+ , istate_feats = []+ , istate_comps = []+ , istate_files = []+ }+ (v, is) <- ia initial_state+ let sorted = map (\ ls@((x,_):_) -> (x,ls)) $+ groupBy (\ (x,_) (y,_) -> x==y) $+ istate_rows is+ return (v, sorted, istate_tables is, istate_replaces is)++ioToIM :: IO a -> IM a+ioToIM act = IM $ \ st -> act >>= \ val -> return (val, st)++addRow :: Row -> IM ()+addRow r = IM $ \ is -> return ((), is{istate_rows=(r:istate_rows is)})++getTableRows :: TableName -> IM [Row]+getTableRows nm = IM $ \ is -> return (filter ((nm==).fst) (istate_rows is), is)++replaceRow :: ReplaceRow -> IM ()+replaceRow r = IM $ \ is -> return ((), is{istate_replaces=(r:istate_replaces is)})++addTable :: Table -> IM ()+addTable t = IM $ \ is -> return ((), is{istate_tables=(t:istate_tables is)})++getComponents :: IM [(Id, Id)]+getComponents = IM $ \ st -> return (istate_comps st, st)++getDirs :: IM [(FilePath, Id)]+getDirs = IM $ \ st -> return (istate_dirs st, st)++addCompMapping :: Id -> Id -> IM ()+addCompMapping compName dirName + = IM $ \ st -> return ((), st{istate_comps=(compName,dirName):istate_comps st})++addDirMapping :: FilePath -> Id -> IM ()+addDirMapping dName dKey+ = IM $ \ st -> return ((), st{istate_dirs=(dName,dKey):istate_dirs st})++addFile :: FilePath -> Id -> Id -> String -> String -> IM ()+addFile fName fKey compKey nm fSize + = IM $ \ st -> + return ((), + st{istate_files=(fName, (fKey,compKey,nm,fSize)):istate_files st})++replaceFile :: FilePath -> (Id, Id, String, String) -> IM ()+replaceFile fName stuff+ = IM $ \ st -> + return ((), + st{istate_files=(fName, stuff):+ filter ((/=fName).fst) (istate_files st)})++getFiles :: IM [(FilePath, (Id, Id, String, String))]+getFiles = IM $ \ st -> return (istate_files st, st)++newId :: IM String+newId = IM $ \ st ->+ case istate_guids st of + (g:gs) -> return (show g, st{istate_guids=gs})++-- an infinite supply of GUIDs.+new_guids :: IO [GUID]+new_guids = do+ x <- newGUID+ xs <- unsafeInterleaveIO new_guids+ return (x : xs)+
+ Bamse/MSIExtra.hs view
@@ -0,0 +1,75 @@+--+-- (c) 2007, Galois, Inc.+--+-- The MSI TLB doesn't provide everything we need to+-- use the object model. This module provides these+-- extra bits.+--+module Bamse.MSIExtra where++import Data.Char ( toUpper )+import Util.Path ( fileSuffix )+import Bamse.Package++-- product ID tags (from MsiDefs.h, not provided in the TLB).+data ProductIDTag+ = PID_DICTIONARY+ | PID_CODEPAGE+ | PID_TITLE+ | PID_SUBJECT+ | PID_AUTHOR+ | PID_KEYWORDS+ | PID_COMMENTS+ | PID_TEMPLATE+ | PID_LASTAUTHOR+ | PID_REVNUMBER+ | PID_EDITTIME+ | PID_LASTPRINTED+ | PID_CREATE_DTM+ | PID_LASTSAVE_DTM+ | PID_PAGECOUNT+ | PID_WORDCOUNT+ | PID_CHARCOUNT+ | PID_THUMBNAIL+ | PID_APPNAME+ | PID_SECURITY+ -- The values for the product tags is identical to the Int+ -- values the derived Enum instance maps onto (in the order+ -- given above), so let's make use of 'deriving' here. This+ -- is all somewhat brittle, though..+ deriving ( Eq, Enum, Show )+ +shortLong :: String -> String+shortLong nm = short_form+ where+ badChars = " +,;=[]"+ restricted_nm = map (\ ch -> if ch `elem` badChars then '_' else ch) nm+ ext = fileSuffix nm+ short_form + | length restricted_nm > 8 || length ext > 3 = take 6 (map toUpper restricted_nm) ++ "~1|" ++ nm+ | otherwise = restricted_nm++data MsidbFileAttributes+ = MsidbFileAttributesReadOnly -- = 0x00000001,+ | MsidbFileAttributesHidden -- = 0x00000002,+ | MsidbFileAttributesSystem -- = 0x00000004,+ | MsidbFileAttributesReserved0 -- = 0x00000008, // Internal use only - must be 0+ | MsidbFileAttributesReserved1 -- = 0x00000040, // Internal use only - must be 0+ | MsidbFileAttributesReserved2 -- = 0x00000080, // Internal use only - must be 0+ | MsidbFileAttributesReserved3 -- = 0x00000100, // Internal use only - must be 0+ | MsidbFileAttributesVital -- = 0x00000200,+ | MsidbFileAttributesChecksum -- = 0x00000400,+ | MsidbFileAttributesPatchAdded -- = 0x00001000, // Internal use only - set by patches+ | MsidbFileAttributesNoncompressed -- = 0x00002000,+ | MsidbFileAttributesCompressed -- = 0x00004000,+ | MsidbFileAttributesReserved4 -- = 0x00008000, // Internal use only - must be 0++-- internal record type gathering up parameters for the MSI writer/generator.+-- +data WriterEnv+ = WriterEnv { w_toolDir :: FilePath+ , w_templateDir :: FilePath+ , w_outFile :: FilePath+ , w_srcDir :: FilePath+ , w_package :: PackageData+ }
+ Bamse/MSITable.hs view
@@ -0,0 +1,2029 @@+--+-- (c) 2007, Galois, Inc.+--+-- Complete set of MSI table definitions (version 2.0)+-- +module Bamse.MSITable+ ( Table+ , TableName+ , TableColumn+ , ColumnValue(..)+ , ColumnName+ , ColType(..)++ , ReplaceRow+ , RowKey++ , Key -- type _ = String+ + , Row+ , RowData+ , Value -- type _ = (ColumnName,Maybe ColumnValue)+ , mkRow -- :: TableName -> [Value] -> Row+ , col -- :: ColumnName -> Maybe ColumnValue -> Value+ , string -- :: String -> ColumnValue+ , int -- :: Int -> ColumnValue+ , long -- :: Int -> ColumnValue+ , file -- :: FilePath -> ColumnValue+ , (-=>)+ + , defineTable -- :: TableName -> [TableColumn] -> Table+ , key -- :: ColumnName -> ColType -> TableColumn+ , notNullable -- :: ColumnName -> ColType -> TableColumn+ , nullable -- :: ColumnName -> ColType -> TableColumn+ + -- standard tables.+ , msiTables -- :: [Table]+ + , newActionText -- :: [Value] -> Row+ , newAdminExecuteSequence -- :: [Value] -> Row+ , newAdminUISequence -- :: [Value] -> Row+ , newAdvtExecuteSequence -- :: [Value] -> Row+ , newAppSearch -- :: [Value] -> Row+ , newBBControl -- :: [Value] -> Row+ , newBillboard -- :: [Value] -> Row+ , newBinary -- :: [Value] -> Row+ , newBindImage -- :: [Value] -> Row+ , newCCPSearch -- :: [Value] -> Row+ , newCheckBox -- :: [Value] -> Row+ , newClass -- :: [Value] -> Row+ , newComboBox -- :: [Value] -> Row+ , newCompLocator -- :: [Value] -> Row+ , newComponent -- :: [Value] -> Row+ , newComplus -- :: [Value] -> Row+ , newControl -- :: [Value] -> Row+ , newControlCondition -- :: [Value] -> Row+ , newControlEvent -- :: [Value] -> Row+ , newCreateFolder -- :: [Value] -> Row+ , newCustomAction -- :: [Value] -> Row+ , newDialog -- :: [Value] -> Row+ , newDirectory -- :: [Value] -> Row+ , newDrLocator -- :: [Value] -> Row+ , newDuplicateFile -- :: [Value] -> Row+ , newEnvironment -- :: [Value] -> Row+ , newError -- :: [Value] -> Row+ , newEventMapping -- :: [Value] -> Row+ , newExtension -- :: [Value] -> Row+ , newFeature -- :: [Value] -> Row+ , newFeatureComponents -- :: [Value] -> Row+ , newFile -- :: [Value] -> Row+ , newFileSFPCatalog -- :: [Value] -> Row+ , newFont -- :: [Value] -> Row+ , newIcon -- :: [Value] -> Row+ , newIniFile -- :: [Value] -> Row+ , newIniLocator -- :: [Value] -> Row+ , newIsolatedComponent -- :: [Value] -> Row+ , newInstallExecuteSequence -- :: [Value] -> Row+ , newInstallUISequence -- :: [Value] -> Row+ , newLaunchCondition -- :: [Value] -> Row+ , newListBox -- :: [Value] -> Row+ , newListView -- :: [Value] -> Row+ , newLockPermissions -- :: [Value] -> Row+ , newMedia -- :: [Value] -> Row+ , newMIME -- :: [Value] -> Row+ , newMoveFile -- :: [Value] -> Row+ , newMsiAssembly -- :: [Value] -> Row+ , newMsiAssemblyName -- :: [Value] -> Row+ , newMsiDigitalCertificate -- :: [Value] -> Row+ , newMsiDigitalSignature -- :: [Value] -> Row+ , newMsiFileHash -- :: [Value] -> Row+ , newMsiPatchHeaders -- :: [Value] -> Row+ , newPatch -- :: [Value] -> Row+ , newPatchPackage -- :: [Value] -> Row+ , newProgId -- :: [Value] -> Row+ , newProperty -- :: [Value] -> Row+ , newRadioButton -- :: [Value] -> Row+ , newRegistry -- :: [Value] -> Row+ , newRegLocator -- :: [Value] -> Row+ , newRemoveFile -- :: [Value] -> Row+ , newRemoveIniFile -- :: [Value] -> Row+ , newRemoveRegistry -- :: [Value] -> Row+ , newReserveCost -- :: [Value] -> Row+ , newSelfReg -- :: [Value] -> Row+ , newServiceControl -- :: [Value] -> Row+ , newServiceInstall -- :: [Value] -> Row+ , newSFPCatalog -- :: [Value] -> Row+ , newShortcut -- :: [Value] -> Row+ , newSignature -- :: [Value] -> Row+ , newTextStyle -- :: [Value] -> Row+ , newTypeLib -- :: [Value] -> Row+ , newUIText -- :: [Value] -> Row+ , newUpgrade -- :: [Value] -> Row+ , newVerb -- :: [Value] -> Row++ + , validateRow -- :: [Table] -> Row -> Maybe String+ + , intTy+ , longTy+ , charTy+ , maxStringTy+ , stdStringTy+ , fileTy++ ) where++import Util.List+import Data.Maybe+import Bamse.PackageUtils ( expandString )++{- Encoding MSI tables in Haskell. ++ Currently we opt for a loose encoding which simply states+ the name of the columns that an MSI defines, and whether that+ that column may have 'null' row entries.+ + A type-safer encoding would be to use types to encode individual+ tables, but that _could_ be layered on top of this encoding.+-}+type Table = (TableName, [TableColumn])+type TableName = String+type TableColumn+ = ( ColumnName+ , ColumnType -- what kind (key, nullable etc.) and type of column it is.+ )+type ColumnName = String++type ColumnType + = ( Bool -- True => NOT NULL.+ , Bool -- True => is primary key.+ , ColType+ )++data ColType+ = CHAR (Maybe Int) -- Just x => size 'x'.+ Bool -- True => localisable+ | LONGCHAR Bool -- True => localisable+ | INT -- represents also INTEGER and SHORT (they're all 16-bit types, I believe).+ | LONG+ | OBJECT++-- Table instances / rows:+type Row = (TableName, [Value])+type Value = (ColumnName, Maybe ColumnValue)++type RowData = [(Int, ColumnValue)]++type ReplaceRow = (TableName, [RowKey], [Value])+type RowKey = (ColumnName, Key)+type Key = String++data ColumnValue+ = String String+ | Int Int+ | Long Int+ | File FilePath+ deriving Show++mkRow :: TableName -> [Value] -> Row+mkRow nm vals = (nm,vals)++col nm v = (nm,v)++(-=>) = col++string :: String -> ColumnValue+string s = String (expandString s)++int :: Int -> ColumnValue+int i = Int i++long :: Int -> ColumnValue+long i = Long i++file :: FilePath -> ColumnValue+file f = File f++key :: ColumnName -> ColType -> TableColumn+key nm ct = (nm, (True, True, ct))++keyNullable :: ColumnName -> ColType -> TableColumn+keyNullable nm ct = (nm, (False, True, ct))++notNullable :: ColumnName -> ColType -> TableColumn+notNullable nm ct = (nm, (True,False,ct))++nullable :: ColumnName -> ColType -> TableColumn+nullable nm ct = (nm, (False, False, ct))++charTy sz = CHAR sz False+fileTy = OBJECT+intTy = INT+longTy = LONG++localisable (CHAR sz _) = CHAR sz True+localisable t = t++-- some common string/text types:+stdStringTy = charTy (Just 72)+maxStringTy = charTy (Just 255)+guidTy = charTy (Just 38)+versionTy = charTy (Just 20)++defineTable :: TableName -> [TableColumn] -> Table+defineTable nm fs = (nm, fs)++validateRow :: [Table]+ -> Row+ -> Maybe String -- Nothing => everything's ok+ -- (there's negative outlook for you,+ -- 'Nothing' to encode success).+validateRow tabs row@(nm, vals) =+ case lookupBy ((nm==).fst) tabs of+ Just (_,cols) -> Just $ unlines $ catMaybes $ + (map (isValidColumn cols) vals +++ map (hasValidColumn vals) cols)+ Nothing -> Just ("Unknown table: " ++ nm)+ where+ hasValidColumn vals (colNm, cVal) = + case cVal of+ -- if the column can contain null or has a default value,+ -- the presence or absense of a value for it in the row won't+ -- make a difference.+ (False,_,_) -> Nothing+ _ -> + case lookupBy ((==colNm).fst) vals of+ Nothing -> Just ("Value not found for required column: " ++ colNm)+ Just{} -> Nothing++ isValidColumn cols (colNm, mbVal) =+ case lookupBy ((colNm==).fst) cols of+ Nothing -> Just ("Unknown column: " ++ colNm)+ Just (_, colVal) ->+ case colVal of+ (_,True,_)+ | not (isJust mbVal) ->+ Just ("Missing value for key column: " ++ colNm)+ | otherwise -> + Nothing+ (True,_,_)+ | not (isJust mbVal) ->+ Just ("Missing value for non-nullable column: " ++ colNm)+ | otherwise ->+ Nothing+ (False,_,_) -> Nothing++msiTables :: [Table]+msiTables =+ [ actionTextTable+ , adminExecuteSequenceTable+ , adminUISequenceTable+ , advtExecuteSequenceTable+ , appIdTable+ , appSearchTable+ , bbControlTable+ , billboardTable+ , binaryTable+ , bindImageTable+ , ccpSearchTable+ , checkBoxTable+ , classTable+ , comboBoxTable+ , compLocatorTable+ , complusTable+ , componentTable+ , controlTable+ , controlConditionTable+ , controlEventTable+ , createFolderTable+ , customActionTable+ , dialogTable+ , directoryTable+ , drLocatorTable+ , duplicateFileTable+ , environmentTable+ , errorTable+ , eventMappingTable+ , extensionTable+ , featureTable+ , featureComponentsTable+ , fileTable+ , fileSFPCatalogTable+ , fontTable+ , iconTable+ , iniFileTable+ , iniLocatorTable+ , isolatedComponentTable+ , installExecuteSequenceTable+ , installUISequenceTable+ , launchConditionTable+ , listBoxTable+ , listViewTable+ , lockPermissionsTable+ , mediaTable+ , mimeTable+ , moveFileTable+ , msiAssemblyTable+ , msiAssemblyNameTable+ , msiDigitalCertificateTable+ , msiDigitalSignatureTable+ , msiFileHashTable+ , msiPatchHeadersTable+ , patchTable+ , patchPackageTable+ , propertyTable+ , progIdTable+ , radioButtonTable+ , registryTable+ , regLocatorTable+ , removeFileTable+ , removeIniFileTable+ , removeRegistryTable+ , reserveCostTable+ , selfRegTable+ , serviceControlTable+ , serviceInstallTable+ , sfpCatalogTable+ , shortcutTable+ , signatureTable+ , textStyleTable+ , typeLibTable+ , uiTextTable+ , upgradeTable+ , verbTable+ ]+++{-+ Purpose: The AdminExecuteSequence table lists actions that the installer calls+ in sequence when the top-level ADMIN action is executed.+-}+actionTextName :: TableName+actionTextName = "ActionText"++actionTextTable :: Table+actionTextTable = + defineTable actionTextName+ [ key "Action" stdStringTy+ , nullable "Condition" maxStringTy+ , nullable "Sequence" maxStringTy+ ]++newActionText :: [Value] -> Row+newActionText vals = mkRow actionTextName vals++{-+ Purpose: The AdminExecuteSequence table lists actions that the installer calls+ in sequence when the top-level ADMIN action is executed.+-}+adminExecuteSequenceName :: TableName+adminExecuteSequenceName = "AdminExecuteSequence"++adminExecuteSequenceTable :: Table+adminExecuteSequenceTable = + defineTable adminExecuteSequenceName+ [ key "Action" stdStringTy+ , nullable "Condition" maxStringTy+ , notNullable "Sequence" intTy+ ]++newAdminExecuteSequence :: [Value] -> Row+newAdminExecuteSequence vals = mkRow adminExecuteSequenceName vals++{-+ Purpose: The AdminUISequence table lists actions that the installer calls+ in sequence when the top-level ADMIN action is executed and the+ internal user interface level is set to full UI or reduced UI.+-}+adminUISequenceName :: TableName+adminUISequenceName = "AdminUISequence"++adminUISequenceTable :: Table+adminUISequenceTable = + defineTable adminUISequenceName+ [ key "Action" stdStringTy+ , nullable "Condition" maxStringTy+ , notNullable "Sequence" intTy+ ]++newAdminUISequence :: [Value] -> Row+newAdminUISequence vals = mkRow adminUISequenceName vals++{-+ Purpose: The AdvtExecuteSequence table lists actions that the installer calls+ in sequence when the top-level ADVERTISE action is executed.+-}+advtExecuteSequenceName :: TableName+advtExecuteSequenceName = "AdvtExecuteSequence"++advtExecuteSequenceTable :: Table+advtExecuteSequenceTable = + defineTable advtExecuteSequenceName+ [ key "Action" stdStringTy+ , nullable "Condition" maxStringTy+ , notNullable "Sequence" intTy+ ]++newAdvtExecuteSequence :: [Value] -> Row+newAdvtExecuteSequence vals = mkRow advtExecuteSequenceName vals++{-+ Purpose: + The AppId table or the Registry table specifies that the+ installer configure and register DCOM servers to do one+ of the following during an installation:++ * Run the DCOM server under a different identity than the user+ activating the server. For example, to configure a DCOM server+ to always run as an interactive user or as a predefined user. ++ * Run the DCOM server as a service. + * Configure the default security access for the DCOM server. + * Register the DCOM server such that it is activated on a + different computer. ++ This table is processed at the installation of the component+ associated with the DCOM server in the _Component column of+ the Class table. An AppId is not advertised.+-}+appIdName :: TableName+appIdName = "AppId"++appIdTable :: Table+appIdTable = + defineTable appIdName+ [ key "AppId" (charTy (Just 38))+ , nullable "RemoteServerName" maxStringTy+ , nullable "LocalService" maxStringTy+ , nullable "ServiceParameters" maxStringTy+ , nullable "DllSurrogate" maxStringTy+ , nullable "ActivateAtStorage" intTy+ , nullable "RunAsInteractiveUser" intTy+ ]++newAppId :: [Value] -> Row+newAppId = mkRow appIdName++{-+ Purpose: The AppSearch table contains properties needed to search + for a file having a particular file signature. The+ AppSearch table can also be used to set a property to+ the existing value of a registry or .ini file entry.+-}+appSearchName :: TableName+appSearchName = "AppSearch"++appSearchTable :: Table+appSearchTable =+ defineTable appSearchName+ [ key "Property" stdStringTy+ , key "Signature_" stdStringTy+ ]++newAppSearch :: [Value] -> Row+newAppSearch = mkRow appSearchName++{-+ Purpose: The BBControl table lists the controls to be + displayed on each billboard.+-}+bbControlName :: TableName+bbControlName = "BBControl"++bbControlTable :: Table+bbControlTable = + defineTable bbControlName+ [ key "Billboard_" stdStringTy+ , key "BBControl" stdStringTy+ , notNullable "Type" stdStringTy+ , notNullable "X" intTy+ , notNullable "Y" intTy+ , notNullable "Width" intTy+ , notNullable "Height" intTy+ , nullable "Attributes" longTy+ , nullable "Text" maxStringTy+ ]++newBBControl :: [Value] -> Row+newBBControl = mkRow bbControlName++{-+ Purpose: The Billboard table lists the billboards displayed+ in the full user interface. A billboard is a part+ of a dialog that dynamically changes on progress+ or through action data messages.+-}+billboardName :: TableName+billboardName = "Billboard"++billboardTable :: Table+billboardTable = + defineTable billboardName+ [ key "Billboard" stdStringTy+ , notNullable "Feature_" stdStringTy+ , nullable "Action" stdStringTy+ , nullable "Ordering" intTy+ ]++newBillboard :: [Value] -> Row+newBillboard = mkRow billboardName++{-+ Purpose: The Binary table holds the binary data for items+ such as bitmaps, animations, and icons. The binary table is+ also used to store data for custom actions. +-}+binaryTableName :: TableName+binaryTableName = "Binary"++binaryTable :: Table+binaryTable =+ defineTable binaryTableName+ [ key "Name" stdStringTy+ , notNullable "Data" fileTy+ ]++newBinary :: [Value] -> Row+newBinary vals = mkRow binaryTableName vals++{-+ Purpose:+ The BindImage table contains information about each+ executable or DLL that needs to be bound to the DLLs+ imported by it.+-}+bindImageName :: TableName+bindImageName = "BindImage"++bindImageTable :: Table+bindImageTable = + defineTable bindImageName+ [ key "File_" stdStringTy+ , nullable "Path" maxStringTy+ ]++newBindImage :: [Value] -> Row+newBindImage = mkRow bindImageName++{-+ Purpose:+ The CCPSearch table contains the list of file signatures+ used for the Compliance Checking Program (CCP). At least+ one of these files needs to be present on a user's computer+ for the user to be in compliance with the program.+-}+ccpSearchName :: TableName+ccpSearchName = "CCPSearch"++ccpSearchTable :: Table+ccpSearchTable =+ defineTable ccpSearchName+ [ key "Signature_" stdStringTy ]++newCCPSearch :: [Value] -> Row+newCCPSearch = mkRow ccpSearchName++{-+ Purpose: The CheckBox table lists the values for the check boxes.+-}+checkBoxName :: TableName+checkBoxName = "CheckBox"++checkBoxTable :: Table+checkBoxTable = + defineTable checkBoxName+ [ key "Property" stdStringTy+ , nullable "Value" maxStringTy+ ]+ +newCheckBox :: [Value] -> Row+newCheckBox = mkRow checkBoxName++{-+ Purpose:+ The Class table contains COM server-related information+ that must be generated as a part of the product advertisement.+ Each row may generate a set of registry keys and values.+ The associated ProgId information is included in this table.+-}+className :: TableName+className = "ClassName"++classTable :: Table+classTable = + defineTable className+ [ key "CLSID" guidTy+ , key "Context" stdStringTy+ , key "Component_" stdStringTy+ , nullable "ProgId_Default" maxStringTy+ , nullable "Description" maxStringTy+ , nullable "AppId_" guidTy+ , nullable "FileTypeMask" maxStringTy+ , nullable "Icon_" stdStringTy+ , nullable "IconIndex" intTy+ , nullable "DefInProcHandler" maxStringTy+ , nullable "Argument" maxStringTy+ , notNullable "Feature_" stdStringTy+ , nullable "Attributes" intTy+ ]++newClass :: [Value] -> Row+newClass = mkRow className++{-+ Purpose:+ The lines of a combo box are not treated as individual+ controls; they are part of a single combo box that+ functions as a control. This table lists the values+ for each combo box.+-}+comboBoxName :: TableName+comboBoxName = "ComboBox"++comboBoxTable :: Table+comboBoxTable = + defineTable comboBoxName+ [ key "Property" stdStringTy+ , key "Order" intTy+ , notNullable "Value" maxStringTy+ , nullable "Text" maxStringTy+ ]++newComboBox :: [Value] -> Row+newComboBox = mkRow comboBoxName++{-+ Purpose:+ The CompLocator table holds the information needed+ to find a file or a directory using the installer+ configuration data.+-}+compLocatorName :: TableName+compLocatorName = "CompLocator"++compLocatorTable :: Table+compLocatorTable = + defineTable compLocatorName+ [ key "Signature_" stdStringTy+ , notNullable "ComponentId" guidTy+ , nullable "Type" intTy+ ]++newCompLocator :: [Value] -> Row+newCompLocator = mkRow compLocatorName++{-+ Purpose:+ The Complus table contains information needed to+ install COM+ applications.+-}+complusName :: TableName+complusName = "Complus"++complusTable :: Table+complusTable = + defineTable complusName+ [ key "Component_" stdStringTy+ , nullable "ExpType" intTy+ ]++newComplus :: [Value] -> Row+newComplus = mkRow complusName++{-+ Purpose: The Component table lists components.+-}+componentName :: TableName+componentName = "Component"++componentTable :: Table+componentTable = + defineTable componentName+ [ key "Component" stdStringTy+ , nullable "ComponentId" (charTy (Just 38))+ , notNullable "Directory_" stdStringTy+ , notNullable "Attributes" intTy+ , nullable "Condition" maxStringTy+ , nullable "KeyPath" stdStringTy+ ]++newComponent :: [Value] -> Row+newComponent vals = mkRow componentName vals++--+-- Table: Control+--+-- Purpose: The Control table defines the controls that appear+-- on each dialog box.+--+controlName :: TableName+controlName = "Control"++controlTable = + defineTable controlName+ [ key "Dialog_" stdStringTy+ , key "Control" (charTy (Just 50))+ , notNullable "Type" (charTy (Just 50))+ , notNullable "X" intTy+ , notNullable "Y" intTy+ , notNullable "Width" intTy+ , notNullable "Height" intTy+ , nullable "Attributes" longTy+ , nullable "Property" (charTy (Just 50))+ , nullable "Text" stdStringTy+ , nullable "Control_Next" (charTy (Just 50))+ , nullable "Help" (charTy (Just 50))+ ]+ +newControl :: [Value] -> Row+newControl vals = mkRow controlName vals++--+-- Table: ControlCondition+--+-- Purpose: The ControlCondition table enables an author to specify+-- special actions to be applied to controls based on the+-- result of a conditional statement. For example, using+-- this table the author could choose to hide a control+-- based on the VersionNT property.+--+controlConditionName :: TableName+controlConditionName = "ControlCondition"++controlConditionTable =+ defineTable controlConditionName+ [ key "Dialog_" stdStringTy+ , key "Control_" (charTy (Just 50))+ , key "Action" (charTy (Just 50))+ , key "Condition" maxStringTy+ ]+ +newControlCondition :: [Value] -> Row+newControlCondition vals = mkRow controlConditionName vals++{-+ Purpose: The ControlEvent table allows the author to specify+ what happens when the user interacts with any control within+ a dialog box. For example, a click of a push button can be+ defined to trigger a transition to another dialog box, to exit+ a dialog box sequence, or to begin file installation. +-}+controlEventName :: TableName+controlEventName = "ControlEvent"++controlEventTable = + defineTable controlEventName+ [ key "Dialog_" stdStringTy+ , key "Control_" (charTy (Just 50))+ , key "Event" (charTy (Just 50))+ , key "Argument" maxStringTy+ , notNullable "Condition" maxStringTy+ , nullable "Ordering" intTy+ ]+ +newControlEvent :: [Value] -> Row+newControlEvent vals = mkRow controlEventName vals++{-+ Purpose: The CreateFolder table contains references to folders that need to be + created explicitly for a particular component.+-}+createFolderName :: TableName+createFolderName = "CreateFolder"++createFolderTable :: Table+createFolderTable = + defineTable createFolderName+ [ key "Directory_" stdStringTy+ , key "Component_" stdStringTy+ ]++newCreateFolder :: [Value] -> Row+newCreateFolder vals = mkRow createFolderName vals++{-+ Purpose: The CustomAction table provides the means of integrating custom code+ and data into the installation.+-}+customActionName :: TableName+customActionName = "CustomAction"++customActionTable :: Table+customActionTable = + defineTable customActionName+ [ key "Action" stdStringTy+ , notNullable "Type" intTy+ , nullable "Source" (charTy (Just 64))+ , nullable "Target" maxStringTy+ ]++newCustomAction :: [Value] -> Row+newCustomAction = mkRow customActionName++--+-- Table: Dialog+-- +-- Purpose: The Dialog table contains all the dialogs that appear+-- in the user interface in both the full and reduced modes.+--+dialogName :: TableName+dialogName = "Dialog"++dialogTable :: Table+dialogTable =+ defineTable dialogName+ [ key "Dialog" stdStringTy+ , notNullable "HCentering" intTy+ , notNullable "VCentering" intTy+ , notNullable "Width" intTy+ , notNullable "Height" intTy+ , nullable "Attributes" longTy+ , nullable "Title" (charTy (Just 128))+ , notNullable "Control_First" (charTy (Just 50))+ , nullable "Control_Default" (charTy (Just 50))+ , nullable "Control_Cancel" (charTy (Just 50))+ ]++newDialog :: [Value] -> Row+newDialog vals = mkRow dialogName vals++{-+ Purpose: The Directory table specifies the directory layout+ for the product. Each row of the table indicates+ a directory both at the source and the target. +-}+directoryName :: TableName+directoryName = "Directory"++directoryTable :: Table+directoryTable =+ defineTable directoryName+ [ key "Directory" stdStringTy+ , nullable "Directory_Parent" stdStringTy+ , notNullable "DefaultDir" (localisable stdStringTy)+ ]++newDirectory :: [Value] -> Row+newDirectory vals = mkRow directoryName vals+++{-+ Purpose: The DrLocator table holds the information needed to + find a file or directory by searching the directory tree.+-}+drLocatorName :: TableName+drLocatorName = "DrLocator"++drLocatorTable :: Table+drLocatorTable =+ defineTable drLocatorName+ [ key "Signature_" stdStringTy+ , keyNullable "Parent" stdStringTy+ , key "Path" maxStringTy+ , nullable "Depth" intTy+ ]++newDrLocator :: [Value] -> Row+newDrLocator = mkRow drLocatorName++{-+ Purpose:+ The DuplicateFile table contains a list of files that are+ to be duplicated, either to a different directory than the+ original file or to the same directory but with a different+ name. The original file must be a file installed by the+ InstallFiles action.+-}+duplicateFileName :: TableName+duplicateFileName = "DuplicateFile"++duplicateFileTable :: Table+duplicateFileTable =+ defineTable duplicateFileName+ [ key "FileKey" stdStringTy+ , notNullable "Component_" stdStringTy+ , notNullable "File_" stdStringTy+ , nullable "DestName" maxStringTy+ , nullable "DestFolder" stdStringTy+ ]++newDuplicateFile :: [Value] -> Row+newDuplicateFile = mkRow duplicateFileName++{-+ Purpose: The Environment table is used to set the value+ of environment variables.+-}+environmentName :: TableName+environmentName = "Environment"++environmentTable :: Table+environmentTable =+ defineTable environmentName+ [ key "Environment" stdStringTy+ , notNullable "Name" (localisable stdStringTy)+ , nullable "Value" (localisable maxStringTy)+ , notNullable "Component_" stdStringTy+ ]++newEnvironment :: [Value] -> Row+newEnvironment vals = mkRow environmentName vals++{-+ Purpose: + The Error table is used to look up error message formatting+ templates when processing errors with an error code set but+ without a formatting template set+ (this is the normal situation).+-}+errorName :: TableName+errorName = "Error"++errorTable :: Table+errorTable =+ defineTable errorName+ [ key "Error" intTy+ , nullable "Message" maxStringTy+ ]++newError :: [Value] -> Row+newError = mkRow errorName++{-+ Purpose: + The EventMapping table lists the controls that subscribe+ to some control event and lists the attribute to be+ changed when the event is published by another control+ or the installer.+-}+eventMappingName :: TableName+eventMappingName = "EventMapping"++eventMappingTable :: Table+eventMappingTable = + defineTable eventMappingName+ [ key "Dialog_" stdStringTy+ , key "Control_" stdStringTy+ , key "Event" stdStringTy+ , nullable "Attribute" stdStringTy+ ]++newEventMapping :: [Value] -> Row+newEventMapping = mkRow eventMappingName++{-+ Purpose: The Extension table contains information about file+ name extension servers that must be generated as+ part of product advertisement. Each row generates a+ set of registry keys and values.+-}+extensionName :: TableName+extensionName = "Extension"++extensionTable :: Table+extensionTable = + defineTable extensionName+ [ notNullable "Extension" maxStringTy+ , notNullable "Component_" stdStringTy+ , nullable "ProgId_" maxStringTy+ , nullable "MIME_" (charTy (Just 64))+ , notNullable "Feature_" (charTy (Just 38))+ ]++newExtension :: [Value] -> Row+newExtension = mkRow extensionName++{-+ Purpose: The Feature table defines the logical tree structure+ of features.+-}+featureName :: TableName+featureName = "Feature"++featureTable :: Table+featureTable = + defineTable featureName+ [ key "Feature" (charTy (Just 38))+ , nullable "Feature_Parent" (charTy (Just 38))+ , nullable "Title" (localisable (charTy (Just 64)))+ , nullable "Description" (localisable maxStringTy)+ , nullable "Display" intTy+ , notNullable "Level" intTy+ , nullable "Directory_" stdStringTy+ , notNullable "Attributes" intTy+ ]++newFeature :: [Value] -> Row+newFeature = mkRow featureName++{-+ Purpose: The FeatureComponents table defines the relationship+ between features and components. For each feature,+ this table lists all the components that make up+ that feature. +-}++featureComponentsName :: TableName+featureComponentsName = "FeatureComponents"++featureComponentsTable :: Table+featureComponentsTable =+ defineTable featureComponentsName+ [ notNullable "Feature_" (charTy (Just 38))+ , notNullable "Component_" stdStringTy+ ]++newFeatureComponents :: [Value] -> Row+newFeatureComponents = mkRow featureComponentsName++{-+ Purpose: The File table contains a complete list of source files+ with their various attributes, ordered by a unique,+ non-localized, identifier. +-}+fileName :: TableName+fileName = "File"++fileTable :: Table+fileTable = + defineTable fileName+ [ key "File" stdStringTy+ , notNullable "Component_" stdStringTy+ , notNullable "FileName" (localisable maxStringTy)+ , notNullable "FileSize" longTy+ , nullable "Version" stdStringTy+ , nullable "Language" (charTy (Just 20))+ , nullable "Attributes" intTy+ , notNullable "Sequence" intTy+ ]++newFile :: [Value] -> Row+newFile = mkRow fileName++{-+ Purpose: The FileSFPCatalog table associates specified files with+ the catalog files used by Windows Millennium Edition for+ Windows File Protection.+-}+fileSFPCatalogName :: TableName+fileSFPCatalogName = "FileSFPCatalog"++fileSFPCatalogTable :: Table+fileSFPCatalogTable =+ defineTable fileSFPCatalogName+ [ key "File_" stdStringTy+ , key "SFPCatalog_" stdStringTy+ ]++newFileSFPCatalog :: [Value] -> Row+newFileSFPCatalog = mkRow fileSFPCatalogName++{-+ Purpose: The Font table contains the information for+ registering font files with the system+-}+fontName :: TableName+fontName = "Font"++fontTable :: Table+fontTable = + defineTable fontName+ [ key "File_" stdStringTy+ , nullable "FontTitle" maxStringTy+ ]++newFont :: [Value] -> Row+newFont = mkRow fontName++{-+ Purpose: The Icon table contains the icon files. Each icon from + the table is copied to a file as a part of product+ advertisement to be used for advertised shortcuts and+ OLE servers.+-}+iconName :: TableName+iconName = "Icon"++iconTable :: Table+iconTable = + defineTable iconName+ [ key "Name" stdStringTy+ , notNullable "Data" fileTy+ ]++newIcon :: [Value] -> Row+newIcon = mkRow iconName++{-+ Purpose: The IniFile table contains the .ini information+ that the application needs to set in an .ini file.+-}+iniFileName :: TableName+iniFileName = "IniFile"++iniFileTable :: Table+iniFileTable = + defineTable iniFileName+ [ key "IniFile" stdStringTy+ , notNullable "FileName" maxStringTy+ , nullable "DirProperty" stdStringTy+ , notNullable "Section" maxStringTy+ , notNullable "Key" maxStringTy+ , notNullable "Value" maxStringTy+ , notNullable "Action" intTy+ , nullable "Component_" stdStringTy+ ]++newIniFile :: [Value] -> Row+newIniFile = mkRow iniFileName++{-+ Purpose: The IniLocator table holds the information needed+ to search for a file or directory using an .ini+ file or to search for a particular .ini entry+ itself. The .ini file must be present in the+ default Microsoft Windows directory.+-}+iniLocatorName :: TableName+iniLocatorName = "IniLocator"++iniLocatorTable :: Table+iniLocatorTable = + defineTable iniLocatorName+ [ key "Signature_" stdStringTy+ , notNullable "FileName" maxStringTy+ , notNullable "Section" maxStringTy+ , notNullable "Key" maxStringTy+ , nullable "Field" intTy+ , nullable "Type" intTy+ ]++newIniLocator :: [Value] -> Row+newIniLocator = mkRow iniLocatorName++{-+ Purpose: The InstallExecuteSequence table lists actions that+ are executed when the top-level INSTALL action is+ executed.+-}+installExecuteSequenceName :: TableName+installExecuteSequenceName = "InstallExecuteSequence"++installExecuteSequenceTable :: Table+installExecuteSequenceTable = + defineTable installExecuteSequenceName+ [ key "Action" stdStringTy+ , nullable "Condition" maxStringTy+ , notNullable "Sequence" intTy+ ]++newInstallExecuteSequence :: [Value] -> Row+newInstallExecuteSequence vals = mkRow installExecuteSequenceName vals++{-+ Purpose: The InstallUISequence table lists actions that are executed when+ the top-level INSTALL action is executed and the internal user+ interface level is set to full UI or reduced UI.+-}+installUISequenceName :: TableName+installUISequenceName = "InstallUISequence"++installUISequenceTable :: Table+installUISequenceTable = + defineTable installUISequenceName+ [ key "Action" stdStringTy+ , nullable "Condition" maxStringTy+ , notNullable "Sequence" intTy+ ]++newInstallUISequence :: [Value] -> Row+newInstallUISequence vals = mkRow installUISequenceName vals++{-+ Purpose: + Each record of the IsolatedComponent table associates the+ component specified in the Component_Application column+ (commonly an .exe) with the component specified in the+ Component_Shared column (commonly a shared DLL). The+ IsolateComponents action installs a copy of Component_Shared+ into a private location for use by Component_Application.+ This isolates the Component_Application from other copies+ of Component_Shared that may be installed to a shared+ location on the computer. See Isolated Components.++ To link one Component_Shared to multiple Component_Application,+ include a separate record for each pair in the+ IsolatedComponents table. The installer copies the files of+ Component_Shared into the directory of each Component_Application+ that is installed.+-}+isolatedComponentName :: TableName+isolatedComponentName = "IsolatedComponent"++isolatedComponentTable :: Table+isolatedComponentTable = + defineTable isolatedComponentName+ [ key "Component_Shared" stdStringTy+ , key "Component_Application" stdStringTy+ ]++newIsolatedComponent :: [Value] -> Row+newIsolatedComponent = mkRow isolatedComponentName++{-+ Purpose:+ The LaunchCondition table is used by the LaunchConditions+ action. It contains a list of conditions that all must be+ satisfied for the installation to begin.+-}+launchConditionName :: TableName+launchConditionName = "LaunchCondition"++launchConditionTable :: Table+launchConditionTable = + defineTable launchConditionName+ [ key "Condition" maxStringTy+ , notNullable "Description" (localisable maxStringTy)+ ]++newLaunchCondition :: [Value] -> Row+newLaunchCondition = mkRow launchConditionName++{-+ Purpose: The lines of a list box are not treated as+ individual controls, but they are part of a+ list box that functions as a control. The+ ListBox table defines the values for all+ list boxes.+-}+listBoxName :: TableName+listBoxName = "ListBox"++listBoxTable :: Table+listBoxTable = + defineTable listBoxName+ [ key "Property" stdStringTy+ , key "Order" intTy+ , notNullable "Value" maxStringTy+ , nullable "Text" maxStringTy+ ]+ +newListBox :: [Value] -> Row+newListBox = mkRow listBoxName++{-+ Purpose: The lines of a ListView are not treated as+ individual controls, but they are part of a+ listview that functions as a control. The+ ListView table defines the values for all+ listviews.+-}+listViewName :: TableName+listViewName = "ListView"++listViewTable :: Table+listViewTable = + defineTable listViewName+ [ key "Property" stdStringTy+ , key "Order" intTy+ , notNullable "Value" maxStringTy+ , nullable "Text" maxStringTy+ , nullable "Binary_" stdStringTy+ ]++newListView :: [Value] -> Row+newListView = mkRow listViewName++{- + Purpose: + The LockPermissions table is used to secure individual+ portions of your application in a locked-down environment.+ It can be used with the installation of files, registry keys,+ and created folders.+-}+lockPermissionsName :: TableName+lockPermissionsName = "LockPermissions"++lockPermissionsTable :: Table+lockPermissionsTable = + defineTable lockPermissionsName+ [ key "LockObject" stdStringTy+ , key "Table" maxStringTy+ , keyNullable "Domain" maxStringTy+ , key "User" maxStringTy+ , nullable "Permission" longTy+ ]++newLockPermissions :: [Value] -> Row+newLockPermissions = mkRow lockPermissionsName++{-+ Purpose: The Media table describes the set of disks that make+ up the source media for the installation.+-}+mediaName :: TableName+mediaName = "Media"++mediaTable :: Table+mediaTable = + defineTable mediaName+ [ notNullable "DiskId" intTy+ , notNullable "LastSequence" intTy+ , nullable "DiskPrompt" (localisable (charTy (Just 64)))+ , nullable "Cabinet" (charTy (Just 32))+ , nullable "VolumeLabel" (charTy (Just 32))+ , nullable "Source" (charTy (Just 32))+ ]++newMedia :: [Value] -> Row+newMedia = mkRow mediaName++{-+ Purpose:+ The MIME table associates a MIME content type with a file+ extension or a CLSID to generate the extension or COM server+ information required for advertisement of the MIME+ (Multipurpose Internet Mail Extensions) content.+-}+mimeName :: TableName+mimeName = "MIME"++mimeTable :: Table+mimeTable = + defineTable mimeName+ [ key "ContentType" maxStringTy+ , notNullable "Extension_" maxStringTy+ , nullable "CLSID" guidTy+ ]++newMIME :: [Value] -> Row+newMIME = mkRow mimeName ++{-+ Purpose:+ This table contains a list of files to be moved or+ copied from a specified source directory to a specified+ destination directory.+-}+moveFileName :: TableName+moveFileName = "MoveFile"++moveFileTable :: Table+moveFileTable = + defineTable moveFileName+ [ key "FileKey" stdStringTy+ , notNullable "Component_" stdStringTy+ , nullable "SourceName" (localisable maxStringTy)+ , nullable "DestName" (localisable maxStringTy)+ , nullable "SourceFolder" maxStringTy+ , notNullable "DestFolder" stdStringTy+ , nullable "Options" intTy+ ]++newMoveFile :: [Value] -> Row+newMoveFile = mkRow moveFileName++{-+ Purpose:+ The MsiAssembly table specifies Windows Installer settings+ for Microsoft® .NET Framework assemblies and Win32®+ assemblies.+-}+msiAssemblyName :: TableName+msiAssemblyName = "MsiAssembly"++msiAssemblyTable :: Table+msiAssemblyTable = + defineTable msiAssemblyName+ [ key "Component_" stdStringTy+ , notNullable "Feature_" stdStringTy+ , nullable "File_Manifest" stdStringTy+ , nullable "File_Application" stdStringTy+ , notNullable "Attributes" intTy+ ]++newMsiAssembly :: [Value] -> Row+newMsiAssembly = mkRow msiAssemblyName++{-+ Purpose:+ The MsiAssembly table and MsiAssemblyName table specify+ Windows Installer settings for common language runtime+ assemblies and Win32® assemblies. +-}+msiAssemblyNameName :: TableName+msiAssemblyNameName = "MsiAssemblyName"++msiAssemblyNameTable :: Table+msiAssemblyNameTable = + defineTable msiAssemblyNameName+ [ key "Component_" stdStringTy+ , key "Name" maxStringTy+ , nullable "Value" maxStringTy+ ]+++newMsiAssemblyName :: [Value] -> Row+newMsiAssemblyName = mkRow msiAssemblyNameName++{-+ Purpose: + The MsiDigitalCertificate table stores certificates in+ binary stream format and associates each certificate+ with a primary key. The primary key is used to share+ certificates among multiple digitally signed objects.+ A digital certificate is a credential that provides a+ means to verify identity.+-}+msiDigitalCertificateName :: TableName+msiDigitalCertificateName = "MsiDigitalCertificate"++msiDigitalCertificateTable :: Table+msiDigitalCertificateTable = + defineTable msiDigitalCertificateName+ [ key "DigitalCertificate" stdStringTy+ , notNullable "CertData" fileTy+ ]++newMsiDigitalCertificate :: [Value] -> Row+newMsiDigitalCertificate = mkRow msiDigitalCertificateName++{- + Purpose: The MsiDigitalSignature table contains the signature+ information for every digitally signed object in the+ installation database.+-}+msiDigitalSignatureName :: TableName+msiDigitalSignatureName = "MsiDigitalSignature"++msiDigitalSignatureTable :: Table+msiDigitalSignatureTable = + defineTable msiDigitalSignatureName+ [ key "Table" stdStringTy+ , key "SignObject" maxStringTy+ , notNullable "DigitalCertificate_" stdStringTy+ , nullable "Hash" fileTy+ ]+ +newMsiDigitalSignature :: [Value] -> Row+newMsiDigitalSignature = mkRow msiDigitalSignatureName++{-+ Purpose:+ The MsiFileHash table is used to store a 128-bit hash of+ a source file provided by the Windows Installer package.+ The hash is split into four 32-bit values and stored in+ separate columns of the table.+-} +msiFileHashName :: TableName+msiFileHashName = "MsiFileHash"++msiFileHashTable :: Table+msiFileHashTable = + defineTable msiFileHashName+ [ key "File_" stdStringTy+ , notNullable "Options" intTy+ , notNullable "HashPart1" longTy+ , notNullable "HashPart2" longTy+ , notNullable "HashPart3" longTy+ , notNullable "HashPart4" longTy+ ]++newMsiFileHash :: [Value] -> Row+newMsiFileHash = mkRow msiFileHashName++{- + Purpose: The MsiPatchHeaders table holds the binary patch+ header streams used for patch validation. A patch+ containing a populated MsiPatchHeaders table can+ only be applied using Windows Installer version+ 2.0 or later.+-}+msiPatchHeadersName :: TableName+msiPatchHeadersName = "MsiPatchHeaders"++msiPatchHeadersTable :: Table+msiPatchHeadersTable = + defineTable msiPatchHeadersName+ [ key "StreamRef" stdStringTy+ , notNullable "Header" fileTy+ ]++newMsiPatchHeaders :: [Value] -> Row+newMsiPatchHeaders = mkRow msiPatchHeadersName++{-+ Purpose:+ The Patch table specifies the file that is to receive a+ particular patch and the physical location of the patch+ files on the media images.+-}+patchName :: TableName+patchName = "Patch"++patchTable :: Table+patchTable = + defineTable patchName+ [ key "File_" stdStringTy+ , key "Sequence" intTy+ , notNullable "PatchSize" longTy+ , notNullable "Attributes" intTy+ , nullable "Header" fileTy+ , nullable "StreamRef_" stdStringTy+ ]++newPatch :: [Value] -> Row+newPatch = mkRow patchName++{-+ Purpose: + The PatchPackage table describes all patch packages that+ have been applied to this product. For each patch package,+ the unique identifier for the patch is provided along with+ information about the media image the on which the patch+ is located.+-}+patchPackageName :: TableName+patchPackageName = "PatchPackage"++patchPackageTable :: Table+patchPackageTable = + defineTable patchPackageName+ [ key "PatchId" guidTy+ , notNullable "Media_" intTy+ ]++newPatchPackage :: [Value] -> Row+newPatchPackage = mkRow patchPackageName++{-+ Purpose: The ProgId table contains information for+ program IDs and version independent program IDs+ that must be generated as a part of the+ product advertisement.+-}+progIdName :: TableName+progIdName = "ProgId"++progIdTable :: Table+progIdTable =+ defineTable progIdName+ [ key "ProgId" maxStringTy+ , nullable "ProgId_Parent" maxStringTy+ , nullable "Class_" (charTy (Just 38))+ , nullable "Description" (localisable $ charTy (Just 38))+ , nullable "Icon_" stdStringTy+ , nullable "IconIndex" intTy+ ]++newProgId :: [Value] -> Row+newProgId = mkRow progIdName++{-+ Purpose: The Property table contains the property names and values+ for all defined properties in the installation. Properties+ with Null values are not present in the table.+-}+propertyName :: TableName+propertyName = "Property"++propertyTable :: Table+propertyTable =+ defineTable propertyName+ [ notNullable "Property" stdStringTy+ , notNullable "Value" (localisable (charTy Nothing))+ ]++newProperty :: [Value] -> Row+newProperty = mkRow propertyName++{-+ Purpose:+ The PublishComponent table associates components listed in+ the Component table with a qualifier text-string and a+ category ID GUID. Components with parallel functionality+ that have been grouped together in this way are referred+ to as qualified components.+-}+publishComponentName :: TableName+publishComponentName = "PublishComponent"++publishComponentTable :: Table+publishComponentTable = + defineTable publishComponentName+ [ key "ComponentId" guidTy+ , key "Qualifier" maxStringTy+ , key "Component_" stdStringTy+ , nullable "AppData" maxStringTy+ , notNullable "Feature_" stdStringTy+ ]++newPublishComponent :: [Value] -> Row+newPublishComponent = mkRow publishComponentName++{-+ Purpose:+ Radio buttons are not treated as individual controls,+ but they are part of a radio button group that functions+ as a RadioButtonGroup control. The RadioButton table lists+ the buttons for all the groups.+-}+radioButtonName :: TableName+radioButtonName = "RadioButton"++radioButtonTable :: Table+radioButtonTable = + defineTable radioButtonName+ [ key "Property" stdStringTy+ , key "Order" intTy+ , notNullable "Value" maxStringTy+ , notNullable "X" intTy+ , notNullable "Y" intTy+ , notNullable "Width" intTy+ , notNullable "Height" intTy+ , nullable "Text" maxStringTy+ , nullable "Help" maxStringTy+ ]++newRadioButton :: [Value] -> Row+newRadioButton = mkRow radioButtonName++{-+ Purpose: The Registry table holds the registry information that+ the application needs to set in the system registry. +-}+registryName :: TableName+registryName = "Registry"++registryTable :: Table+registryTable = + defineTable registryName+ [ key "Registry" stdStringTy+ , notNullable "Root" intTy+ , notNullable "Key" (localisable $ maxStringTy)+ , nullable "Name" (localisable $ maxStringTy)+ , nullable "Value" (localisable $ charTy Nothing)+ , notNullable "Component_" stdStringTy+ ]++newRegistry :: [Value] -> Row+newRegistry = mkRow registryName++{-+ Purpose: The RegLocator table holds the information needed to search for+ a file or directory using the registry, or to search for a+ particular registry entry itself.+-}+regLocatorName :: TableName+regLocatorName = "RegLocator"++regLocatorTable :: Table+regLocatorTable = + defineTable regLocatorName+ [ key "Signature_" stdStringTy+ , notNullable "Root" intTy+ , notNullable "Key" (maxStringTy)+ , nullable "Name" (maxStringTy)+ , nullable "Type" intTy+ ]++newRegLocator :: [Value] -> Row+newRegLocator = mkRow regLocatorName++{- + Purpose:+ The RemoveFile table contains a list of files to be removed+ by the RemoveFiles action. Setting the FileName column of+ this table to Null supports the removal of empty folders.+-}+removeFileName :: TableName+removeFileName = "RemoveFile"++removeFileTable :: Table+removeFileTable = + defineTable removeFileName+ [ key "FileKey" stdStringTy+ , notNullable "Component_" stdStringTy+ , nullable "FileName" (localisable maxStringTy)+ , notNullable "DirProperty" stdStringTy+ , notNullable "InstallMode" intTy+ ]++newRemoveFile :: [Value] -> Row+newRemoveFile = mkRow removeFileName++{-+ Purpose:+ The RemoveIniFile table contains the information an application+ needs to delete from a .ini file.+-}+removeIniFileName :: TableName+removeIniFileName = "RemoveIniFile"++removeIniFileTable :: Table+removeIniFileTable = + defineTable removeIniFileName+ [ key "RemoveIniFile" stdStringTy+ , notNullable "FileName" maxStringTy+ , nullable "DirProperty" stdStringTy+ , notNullable "Section" maxStringTy+ , notNullable "Key" maxStringTy+ , nullable "Value" maxStringTy+ , notNullable "Action" intTy+ , notNullable "Component_" stdStringTy+ ]++newRemoveIniFile :: [Value] -> Row+newRemoveIniFile = mkRow removeIniFileName++{-+ Purpose:+ The RemoveRegistry table contains the registry+ information the application needs to delete from+ the system registry.+-}+removeRegistryName :: TableName+removeRegistryName = "RemoveRegistry"++removeRegistryTable :: Table+removeRegistryTable = + defineTable removeRegistryName+ [ key "RemoveRegistry" stdStringTy+ , notNullable "Root" intTy+ , notNullable "Key" maxStringTy+ , nullable "Name" maxStringTy+ , notNullable "Component_" stdStringTy+ ]++newRemoveRegistry :: [Value] -> Row+newRemoveRegistry = mkRow removeRegistryName++{-+ Purpose:+ The ReserveCost table is an optional table that allows+ the author to reserve an amount of disk space in any+ directory that depends on the installation state of+ a component.+-}+reserveCostName :: TableName+reserveCostName = "ReserveCost"++reserveCostTable :: Table+reserveCostTable =+ defineTable reserveCostName+ [ key "ReserveKey" stdStringTy+ , notNullable "Component_" stdStringTy+ , nullable "ReserveFolder" stdStringTy+ , notNullable "ReserveLocal" longTy+ , notNullable "ReserveSource" longTy+ ] ++newReserveCost :: [Value] -> Row+newReserveCost = mkRow reserveCostName++{-+ Purpose:+ The SelfReg table contains information about modules+ that need to be self registered. The installer calls+ the DllRegisterServer function during installation of+ the module; it calls DllUnregisterServer during+ uninstallation of the module. The installer does not+ self register EXE files.+-}+selfRegName :: TableName+selfRegName = "SelfReg"++selfRegTable :: Table+selfRegTable = + defineTable selfRegName+ [ key "File_" stdStringTy+ , nullable "Cost" intTy+ ]++newSelfReg :: [Value] -> Row+newSelfReg = mkRow selfRegName++{-+ Purpose:+ The ServiceControl table is used to control installed+ or uninstalled services.+-}+serviceControlName :: TableName+serviceControlName = "ServiceControl"++serviceControlTable :: Table+serviceControlTable = + defineTable serviceControlName+ [ key "ServiceControl" stdStringTy+ , notNullable "Name" maxStringTy+ , notNullable "Event" intTy+ , nullable "Arguments" maxStringTy+ , nullable "Wait" intTy+ , notNullable "Component_" stdStringTy+ ]++newServiceControl :: [Value] -> Row+newServiceControl = mkRow serviceControlName++{-+ Purpose: The ServiceInstall table is used to install a service and has the+ following columns.+-}+serviceInstallName :: TableName+serviceInstallName = "ServiceInstall"++serviceInstallTable :: Table+serviceInstallTable = + defineTable serviceInstallName+ [ key "ServiceInstall" stdStringTy+ , notNullable "Name" (localisable maxStringTy)+ , nullable "DisplayName" (localisable maxStringTy)+ , notNullable "ServiceType" intTy+ , notNullable "StartType" intTy+ , notNullable "ErrorControl" intTy+ , nullable "LoadOrderGroup" (localisable maxStringTy)+ , nullable "Dependencies" (localisable maxStringTy)+ , nullable "StartName" (localisable maxStringTy)+ , nullable "Password" (localisable maxStringTy)+ , nullable "Arguments" (localisable maxStringTy)+ , notNullable "Component_" stdStringTy+ , nullable "Description" (localisable maxStringTy)+ ]++newServiceInstall :: [Value] -> Row+newServiceInstall = mkRow serviceInstallName++{-+ Purpose:+ The SFPCatalog table contains the catalogs used by+ Windows Millennium Edition for Windows File Protection.+-}+sfpCatalogName :: TableName+sfpCatalogName = "SFPCatalog"++sfpCatalogTable :: Table+sfpCatalogTable = + defineTable sfpCatalogName+ [ key "SFPCatalog" (localisable maxStringTy)+ , notNullable "Catalog" fileTy+ , nullable "Dependency" maxStringTy+ ]++newSFPCatalog :: [Value] -> Row+newSFPCatalog = mkRow sfpCatalogName++{-+ Purpose: The Shortcut table holds the information the application+ needs to create shortcuts on the user's computer. +-}+shortcutName :: TableName+shortcutName = "Shortcut"++shortcutTable :: Table+shortcutTable =+ defineTable shortcutName+ [ key "Shortcut" stdStringTy+ , notNullable "Directory_" stdStringTy+ , notNullable "Name" (localisable $ charTy (Just 128))+ , notNullable "Component_" stdStringTy+ , notNullable "Target" stdStringTy+ , nullable "Arguments" maxStringTy+ , nullable "Description" (localisable maxStringTy)+ , nullable "Hotkey" intTy+ , nullable "Icon_" stdStringTy+ , nullable "IconIndex" intTy+ , nullable "ShowCmd" intTy+ , nullable "WkDir" stdStringTy+ ]++newShortcut :: [Value] -> Row+newShortcut = mkRow shortcutName++{-+ Purpose: The Signature table holds the information that uniquely + identifies a file signature+-}+signatureName :: TableName+signatureName = "Signature"++signatureTable :: Table+signatureTable =+ defineTable signatureName+ [ key "Signature" stdStringTy+ , notNullable "FileName" (localisable maxStringTy)+ , nullable "MinVersion" (charTy (Just 20))+ , nullable "MaxVersion" (charTy (Just 20))+ , nullable "MinSize" longTy+ , nullable "MaxSize" longTy+ , nullable "MinDate" longTy+ , nullable "MaxDate" longTy+ , nullable "Languages" (localisable maxStringTy)+ ]++newSignature :: [Value] -> Row+newSignature = mkRow signatureName++{-+ Purpose:+ The TextStyle table lists different font styles used+ in controls having text.+-}+textStyleName :: TableName+textStyleName = "TextStyle"++textStyleTable :: Table+textStyleTable = + defineTable textStyleName+ [ key "TextStyle" stdStringTy+ , notNullable "FaceName" maxStringTy+ , notNullable "Size" intTy+ , nullable "Color" longTy+ , nullable "StyleBits" intTy+ ]++newTextStyle :: [Value] -> Row+newTextStyle = mkRow textStyleName++{-+ Purpose:+ The TypeLib table contains the information that needs+ to be placed in the registry registration of type libraries.+-}+typeLibName :: TableName+typeLibName = "TypeLib"++typeLibTable :: Table+typeLibTable = + defineTable typeLibName+ [ key "LibID" guidTy+ , key "Language" intTy+ , key "Component_" stdStringTy+ , nullable "Version" intTy+ , nullable "Description" (localisable maxStringTy)+ , nullable "Directory_" stdStringTy+ , notNullable "Feature_" stdStringTy+ , nullable "Cost" longTy+ ]++newTypeLib :: [Value] -> Row+newTypeLib = mkRow typeLibName++{-+ Purpose:+ The UIText table contains the localized versions of+ some of the strings used in the user interface. These+ strings are not part of any other table. The UIText+ table is for strings that have no logical place in+ any other table.+-}+uiTextName :: TableName+uiTextName = "UIText"++uiTextTable :: Table+uiTextTable = + defineTable uiTextName+ [ key "Key" stdStringTy+ , nullable "Text" (localisable maxStringTy)+ ]+ ++newUIText :: [Value] -> Row+newUIText = mkRow uiTextName++{-+ Purpose:+ The Upgrade table contains information required+ during major upgrades. To fully enable the installer's+ upgrade capabilities, every package should have an+ UpgradeCode property and an Upgrade table. +-}+upgradeName :: TableName+upgradeName = "Upgrade"++upgradeTable :: Table+upgradeTable = + defineTable upgradeName+ [ key "UpgradeCode" guidTy+ , key "VersionMin" versionTy+ , key "VersionMax" versionTy+ , key "Language" (localisable maxStringTy)+ , key "Attributes" intTy+ , nullable "Remove" maxStringTy+ , notNullable "ActionProperty" stdStringTy+ ]+ +newUpgrade :: [Value] -> Row+newUpgrade = mkRow upgradeName++{-+ Purpose: The Verb table contains command-verb information+ associated with file extensions that must be generated+ as a part of product advertisement. Each row generates+ a set of registry keys and values. +-}+verbName :: TableName+verbName = "Verb"++verbTable :: Table+verbTable = + defineTable verbName+ [ notNullable "Extension_" maxStringTy+ , key "Verb" (charTy (Just 32))+ , nullable "Sequence" intTy+ , nullable "Command" (localisable maxStringTy)+ , nullable "Argument" (localisable maxStringTy)+ ]++newVerb :: [Value] -> Row+newVerb = mkRow verbName+
+ Bamse/Options.hs view
@@ -0,0 +1,223 @@+--+-- (c) 2007, Galois, Inc.+--+module Bamse.Options where++import Bamse.Package+import Bamse.Writer ( getProductCodes )++import System+import Util.GetOpts++-- for validateOptions / getOptions:+import System.Win32.Com ( newGUID, guidToString )+import System.IO ( hPutStrLn, stderr, stdout )+import Data.Maybe ( isNothing, fromJust )+import Control.Monad ( when )+import Util.Path+import System.Win32.Com.Base ( getModuleFileName )+import Foreign.Ptr ( nullPtr )+import Bamse.PackageUtils ( addEnvVar )++parseArgs :: [String] -> IO (Options, [FilePath])+parseArgs argv = + case getOpt2 Permute options argv initOpts of+ (o,n,[] ) -> return (o,n)+ (_,_,errs) -> do+ prog <- getProgName+ fail $ concat errs ++ help prog++data Options+ = Options { opt_verbose :: Bool+ , opt_version :: Bool+ , opt_help :: Bool+ , opt_update :: Bool+ , opt_showInfo :: Bool+ , opt_genGUIDs :: Bool+ , opt_outFile :: Maybe FilePath+ , opt_productGUID :: Maybe String+ , opt_revisionGUID :: Maybe String+ , opt_srcDir :: Maybe FilePath+ , opt_dataDir :: Maybe FilePath+ , opt_toolDir :: Maybe FilePath+ , opt_ienv :: InstallEnv+ , opt_defines :: [String]+ }+ deriving Show++initOpts :: Options+initOpts + = Options { opt_verbose = False+ , opt_version = False+ , opt_update = False+ , opt_help = False+ , opt_showInfo= False+ , opt_genGUIDs= False+ , opt_outFile = Nothing+ , opt_productGUID = Nothing+ , opt_revisionGUID = Nothing+ , opt_srcDir = Nothing+ , opt_dataDir = Nothing+ , opt_toolDir = Nothing+ , opt_ienv = error "initOpts.opt_ienv: not filled in"+ , opt_defines = []+ }++versionStr = "<installer>"++help :: String -> String+help prog = usageInfo2 header options+ where header = versionStr ++ "\nUsage: " ++ prog ++ " [OPTION...]"++options :: [OptDescr (Options -> Options)]+options =+ [ Option ['v'] ["verbose"] (NoArg (\ op -> op{opt_verbose=True}))+ "Display processing details"+ , Option ['V'] ["version"] (NoArg (\ op -> op{opt_version=True}))+ "Display version number"+ , Option ['h','?'] ["help"] (NoArg (\ op -> op{opt_help=True}))+ "Display this information"+ , Option ['u'] ["update"] (NoArg (\ op -> op{opt_update=True}))+ "Update existing installer (requires -o)"+ , Option [] ["info"] (NoArg (\ op -> op{opt_showInfo=True}))+ "Show info on installer (requires -o)"+ , Option ['o'] ["output"]+ (ReqArg (\ s op -> op{opt_outFile=Just s}) "<file>")+ "Output installer to <file>"+ , Option [] ["product-guid"]+ (ReqArg (\ s op -> op{opt_productGUID=Just (toGUID s)}) "<guid>")+ "Use <guid> as ProductCode. Required arg without -u"+ , Option [] ["revision-guid"]+ (ReqArg (\ s op -> op{opt_revisionGUID=Just (toGUID s)}) "<guid>")+ "Use <guid> as RevisionCode. Required arg without -u"+ , Option [] ["src-dir"]+ (ReqArg (\ s op -> op{opt_srcDir=Just s}) "<dir>")+ "Use <dir> as the path to the directory tree containing the files you want to build an installer for."+ , Option [] ["tool-dir"]+ (ReqArg (\ s op -> op{opt_toolDir=Just s}) "<dir>")+ "Use <dir> as the top of the installer tool's own directory tree."+ , Option [] ["data-dir"]+ (ReqArg (\ s op -> op{opt_dataDir=Just s}) "<dir>")+ "Use <dir> as your installer's data directory."+ , Option [] ["generate-guids"]+ (NoArg (\ op -> op{opt_genGUIDs=True}))+ "Generate new GUIDs for ProductCode and RevisionCode"+ , Option ['D'] []+ (ReqArg (\ s op -> op{opt_defines=s:opt_defines op}) "VAR=VAL")+ "Expand occurrences of $<VAR> in strings to VAL at MSI build-time"+ ]+ where+ toGUID xs@('{':_) = xs -- '}'+ toGUID ls = '{':ls ++ "}"++helpError = do+ showHelp+ exitWith (ExitFailure 1)++showHelp = do+ p <- getProgName+ hPutStrLn stderr (help p)++validateOptions :: FilePath -> Options -> [FilePath] -> IO Options+validateOptions defOut opts inps = do+ -- the top of the install tree must be given.+ opts <-+ if not (opt_showInfo opts) && isNothing (opt_srcDir opts) && length inps /= 1+ then helpError+ else if isNothing (opt_srcDir opts)+ then return opts{opt_srcDir=Just (head inps)}+ else return opts+ -- if in update mode, an output file is reqd.+ opts <- + if opt_update opts+ then if isNothing (opt_outFile opts)+ then do+ let opts' = opts{opt_outFile=Just defOut}+ hPutStrLn stderr ("WARNING: no output file given, using: " ++ fromJust (opt_outFile opts'))+ return opts'+ else+ return opts+ else return opts+ -- if not in update mode, better give the GUIDs+ opts <-+ if not (opt_update opts) && not (opt_showInfo opts)+ then if isNothing (opt_productGUID opts) && not (opt_genGUIDs opts)+ then do+ hPutStrLn stderr ("ERROR: missing product GUID option")+ helpError+ else if opt_genGUIDs opts+ then do+ g <- newGUID+ let n = guidToString g+ n `seq` return opts{opt_productGUID=Just n}+ else+ return opts+ else return opts+ opts <-+ if not (opt_update opts) && not (opt_showInfo opts)+ then if isNothing (opt_revisionGUID opts) && not (opt_genGUIDs opts)+ then do+ hPutStrLn stderr ("ERROR: missing revision GUID option")+ helpError+ else if opt_genGUIDs opts+ then do+ g <- newGUID+ let n = guidToString g+ n `seq` return opts{opt_revisionGUID=Just n}+ else+ return opts+ else return opts+ opts <- + if isNothing (opt_dataDir opts)+ then do+ let opts' = opts{opt_dataDir=opt_toolDir opts}+ hPutStrLn stderr ("WARNING: no data-dir given, setting it equal to tool-dir")+ return opts'+ else return opts+ return opts++getOptions :: FilePath -> IO Options+getOptions defOut = do+ ls <- getArgs+ (opts, inps) <- parseArgs ls+ opts <- validateOptions defOut opts inps+ opts <-+ if opt_update opts || opt_showInfo opts+ then do { (a,b) <- getProductCodes (fromJust (opt_outFile opts)) ;+ return opts{ opt_productGUID = Just a+ , opt_revisionGUID = Just b+ } }+ else return opts+ when (opt_help opts) (showHelp >> exitWith ExitSuccess)+ when (opt_version opts) (hPutStrLn stderr versionStr >> exitWith ExitSuccess)+ when (opt_showInfo opts) $ do+ hPutStrLn stdout $ "Product code: " ++ fromJust (opt_productGUID opts)+ hPutStrLn stdout $ "Revision code: " ++ fromJust (opt_revisionGUID opts)+ exitWith ExitSuccess+ mapM_ processDefine (opt_defines opts)+ let+ srcDir = + case opt_srcDir opts of+ Nothing -> error "no srcDir"+ Just x -> toPlatformPath (joinPath $ splitPath x)+ oFile = + case opt_outFile opts of+ Nothing -> toPlatformPath defOut+ Just x -> toPlatformPath x++ bfile <- getModuleFileName nullPtr+ let bdir = toPlatformPath $ appendSep (dirname bfile)+ let ienv = InstallEnv+ { toolDir = bdir+ , srcDir = srcDir+ , distDir = error "distDir not filled in yet"+ , outFile = oFile+ }+ return opts{opt_ienv=ienv}++processDefine :: String -> IO ()+processDefine str = + case break (=='=') str of+ (as,[]) -> addEnvVar as ""+ (as,_:bs) -> addEnvVar as bs+
+ Bamse/Package.hs view
@@ -0,0 +1,192 @@+--+-- (c) 2007, Galois, Inc.+--+-- Meta information describing an MSI package/product.+-- Whatever the front-end, this is what a package spec+-- boils down to.+--+module Bamse.Package+ ( module Bamse.Package+ , module Bamse.GhcPackage+ , module Bamse.Dialog+ ) where++import Util.Dir ( DirTree )+import Bamse.Dialog+import Bamse.GhcPackage++-- +-- The functions provided by a template are parameterised over+-- the context the installer eventually runs in. Apart from +-- having access to the toplevel directory of the distribution/install+-- tree, these functions also have access to the directory of+-- the installer tool itself (useful for getting at standard files+-- like icons etc.) plus a install-specific outside of the distribution+-- tree which may contain useful installer specific files/data.+-- +data InstallEnv+ = InstallEnv + { toolDir :: FilePath -- where installer tool lives + , srcDir :: FilePath -- path to toplevel directory of files to be distributed.+ , distDir :: FilePath -- user-supplied path to directory containing installer+ -- template specific files.+ , outFile :: FilePath -- file to output installer as.+ }+ deriving Show++data Package+ = Package { name :: String+ , title :: String+ -- productVersion format:+ -- major.minor.build[.whatever]+ -- + , productVersion :: String+ , author :: String+ , comment :: String+ }++type FeatureName = String++type Feature = ( FeatureName -- feature id/name+ , String -- feature descriptive name+ )++data PackageData+ = PackageData { p_files :: DirTree+ , p_fileMap :: InstallEnv -> IO DirTree+ , p_distFileMap :: Maybe (FilePath -> Maybe FilePath)+ , p_defOutFile :: FilePath+ , p_pkgInfo :: Package+ , p_webSite :: String+ , p_bannerBitmap :: InstallEnv -> Maybe FilePath+ , p_bgroundBitmap :: InstallEnv -> Maybe FilePath+ , p_registry :: [RegEntry]+ , p_baseFeature :: Feature+ , p_features :: [Tree Feature]+ , p_featureMap :: Maybe (FilePath -> FeatureName)+ , p_startMenu :: InstallEnv -> (String, [Shortcut])+ , p_desktopShortcuts :: InstallEnv -> [Shortcut]+ , p_extensions :: InstallEnv -> [Extension]+ , p_verbs :: [Verb]+ , p_license :: InstallEnv -> Maybe FilePath+ , p_userRegistration :: Bool+ , p_defaultInstallFolder :: Maybe String+ , p_userInstall :: Bool+ , p_dialogs :: [Dialog]+ , p_finalMessage :: Maybe String+ , p_notForAll :: Bool+ , p_services :: [Service]+ , p_productGUID :: String -- expected form: "{...}"+ , p_revisionGUID :: String -- ditto+ , p_nestedInstalls :: [(FilePath, Maybe String)]+ , p_ghcPackage :: Maybe GhcPackage+ , p_ienv :: InstallEnv+ , p_verbose :: Bool+ }++defPackageData :: PackageData+defPackageData + = PackageData { p_files = fieldError "files"+ , p_fileMap = fieldError "fileMap"+ , p_distFileMap = fieldError "distFileMap"+ , p_defOutFile = fieldError "defOutFile"+ , p_pkgInfo = fieldError "pkgInfo"+ , p_webSite = fieldError "webSite"+ , p_bannerBitmap = fieldError "bannerBitmap"+ , p_bgroundBitmap = fieldError "bgroundBitmap"+ , p_registry = fieldError "registry"+ , p_baseFeature = fieldError "baseFeature"+ , p_features = fieldError "features"+ , p_featureMap = fieldError "featureMap"+ , p_startMenu = fieldError "startMenu"+ , p_desktopShortcuts = fieldError "desktopShortcuts"+ , p_extensions = fieldError "extensions"+ , p_verbs = fieldError "verbs"+ , p_license = fieldError "license"+ , p_userRegistration = fieldError "userRegistration"+ , p_defaultInstallFolder = fieldError "defaultInstallFolder"+ , p_userInstall = fieldError "userInstall"+ , p_dialogs = fieldError "dialogs"+ , p_finalMessage = fieldError "finalMessage"+ , p_notForAll = fieldError "notForAll"+ , p_services = fieldError "services"+ , p_productGUID = fieldError "productGUID"+ , p_revisionGUID = fieldError "revisionGUID"+ , p_ghcPackage = fieldError "ghcPackage"+ , p_nestedInstalls = fieldError "nestedInstalls"+ , p_ienv = fieldError "ienv"+ , p_verbose = fieldError "verbose"+ }+ where+ fieldError f = error ("defPackageData.p_" ++ f ++ ": not filled in")++-- various supporting types that don't quite belong here..+data Shortcut+ = Shortcut+ { scut_name :: String -- name+ , scut_target :: String -- target app+ , scut_args :: String -- arguments+ , scut_desc :: String -- description+ , scut_icon :: Maybe FilePath -- icon file+ , scut_istate :: Int -- initial state+ , scut_wdir :: String -- working dir.+ }++type Extension+ = ( String -- progID, "HaskellFile"+ , String -- application, "hugs.exe"+ , String -- icon, "icon.exe"+ , String -- the extension "lhs"+ )++type Verb+ = ( String -- file extension it applies to+ , String -- name of shell extension+ , String -- label to use in context menus+ , String -- arguments+ )++--+-- Type: RegEntry+--+-- Purpose: describe a Registry entry to be installed and, quite+-- possibly, removed during uninstallation.+-- +data RegEntry+ = RegEntry String -- hive name "HKLM" => HKEY_LOCAL_MACHINE etc.+ String -- key within hive "Software\\Haskell\\Hugs"+ KeyAction++data KeyAction+ = CreateKey Bool -- True => delete on uninstall.+ | CreateName (Maybe String) String -- Nothing => default (unnamed) name/entry for key.+ | DeleteKey Bool -- True => delete key on _install_+ -- False => delete key on _uninstall_+ | DeleteName Bool String -- True => delete name on _install_+ -- False => delete name on _uninstall_+ ++--+-- Type: Service+-- +-- Purpose: User-level type that describes how an NT Service+-- is to be installed.+--+data Service+ = Service { serv_name :: String+ , serv_dispName :: String+ -- ToDo: add custom/ad-hoc data types for the next three?+ , serv_type :: Int+ , serv_start :: Int+ , serv_error :: Int+ , serv_user_pwd :: Maybe (String,String)+ , serv_args :: [String]+ , serv_binary :: FilePath+ , serv_descr :: String+ }++-- for use with feature trees.+data Tree a+ = Leaf a+ | Node a [Tree a]+
+ Bamse/PackageGen.hs view
@@ -0,0 +1,932 @@+--+-- (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+ ]
+ Bamse/PackageUtils.hs view
@@ -0,0 +1,142 @@+--+-- (c) 2007, Galois, Inc.+--+-- Misc helper functions that come in handy when+-- defining installer modules.+--+module Bamse.PackageUtils where++import Bamse.Package++import Util.Path ( appendPath, toPlatformPath, fileSuffix )+import System.Path (isSeparator)++import Data.IORef+import System.IO.Unsafe ( unsafePerformIO )+import System.Environment+import Debug.Trace ( trace )++-- | convert (base) filename to MSI output filename, appending+-- the .msi suffix + doing away with troublesome characters.+toMsiFileName :: FilePath -> FilePath+toMsiFileName f = map dotToDash f ++ ".msi"+ +dotToDash :: Char -> Char+dotToDash '.' = '-'+dotToDash x = x++lFile :: FilePath -> FilePath -> FilePath+lFile dir f = toPlatformPath $ appendPath dir f+ -- sigh, Util.Path.appendPath inserts a forward slash, not+ -- the platform default one, so we need to normalize the path+ -- afterwards.++-- classifying files according to their extension/suffix:+isHiFile :: FilePath -> Bool+isHiFile fn = + case fileSuffix fn of+ "hi" -> True+ _:'_':'h':'i':[] -> True+ _ -> False++isDocFile :: FilePath -> Bool+isDocFile fn = fileSuffix fn `elem` ["html", "pdf", "dvi", "doc", "ps"]++isHeaderFile :: FilePath -> Bool+isHeaderFile fn = fileSuffix fn `elem` ["h"]++dropDirPrefix :: FilePath -> FilePath -> FilePath+dropDirPrefix [] f = dropWhile isSeparator f+dropDirPrefix _ [] = []+dropDirPrefix (x:xs) (y:ys)+ | x == y = dropDirPrefix xs ys+ | otherwise = dropWhile isSeparator (y:ys)+++-- to support build-time definitions in strings (via $<FOO>)+addEnvVar :: String -> String -> IO ()+addEnvVar var val = do+ ls <- readIORef env_list+ writeIORef env_list ((var,val):ls)++env_list :: IORef [(String,String)]+env_list = unsafePerformIO (newIORef [])++env :: String -> String+env s = + case mbEnv s of+ Nothing -> ""+ Just v -> v++expandString :: String -> String+expandString [] = []+expandString ('$':'<':xs) = + case break isTerm xs of+ (as,[]) -> '$' : '<' : expandString xs+ (var,y:ys) -> + case mbEnv var of+ Nothing -> + case y of+ ':' -> + case getDefault ys of+ (as,bs) -> as ++ expandString bs+ _ -> '$':'<' : expandString xs+ Just val -> + trace ("Expanding variable " ++ show var ++ " to " ++ show val) $+ val ++ + case y of+ ':' -> expandString (snd $ getDefault ys)+ _ -> expandString ys+ where+ isTerm '>' = True+ isTerm ':' = True+ isTerm _ = False+ + getDefault [] = ([],[])+ getDefault ('\\':'>':xs) = let (as,bs) = getDefault xs in ('>':as,bs)+ getDefault ('>':xs) = ([],xs)+ getDefault (x:xs) = let (as,bs) = getDefault xs in (x:as,bs)+expandString (x:xs) = x : expandString xs++mbEnv :: String -> Maybe String+mbEnv s = unsafePerformIO $+ catch (fmap Just (getEnv s))+ (\ _ -> do+ ls <- readIORef env_list+ return (lookup s ls))++haskellProject nm values+ = RegEntry "OnInstall" "Software" (CreateKey False) :+ RegEntry "OnInstall" "Software\\Haskell" (CreateKey False) :+ RegEntry "OnInstall" "Software\\Haskell\\Projects" (CreateKey False) :+ RegEntry "OnInstall" proj_path (CreateKey True) :+ map (\ (nm,val) -> RegEntry "OnInstall" proj_path+ (CreateName (Just nm) val))+ values+ where+ proj_path = "Software\\Haskell\\Projects\\"++nm++haskellImpl nm version values+ = RegEntry "OnInstall" "Software" (CreateKey False) :+ RegEntry "OnInstall" "Software\\Haskell" (CreateKey False) :+ RegEntry "OnInstall" impl_path (CreateKey False) :+ RegEntry "OnInstall" impl_path (CreateName (Just "InstallDir") "[TARGETDIR]") :+ RegEntry "OnInstall" ver_path (CreateKey True) :+ map (\ (nm,val) -> RegEntry "OnInstall" ver_path (CreateName (Just nm) val))+ values+ where+ impl_path = "Software\\Haskell\\"++nm+ ver_path = "Software\\Haskell\\"++nm ++ '\\':version++hugsPath val = ("hugsPath", val)++haskellExtension :: FilePath -> FilePath -> FilePath -> String -> Extension+haskellExtension binary topDir bamseDir ext + = ( "HaskellFile"+ , binary+ , lFile iconDir "hs2.exe"+ , ext+ )+ where+ iconDir = lFile bamseDir "icons"+
+ Bamse/WindowsInstaller.hs view
@@ -0,0 +1,1817 @@+-- Automatically generated by HaskellDirect (ihc.exe), version 0.18+-- Created: 11:52 Pacific Standard Time, Friday 16 November, 2001+-- Command line: --tlb -odir . d:/winnt/system32/msi.dll -v -dshow-passes -fno-export-list++module Bamse.WindowsInstaller where++import qualified Prelude+import qualified System.Win32.Com.Automation as Automation+ (IDispatch, outString, inString, + propertyGet, propertySet, method0, Variant, outVariant, inInt32, + inVariant, outInt32, outIUnknown, function1, inEnum, outBool, + outIDispatch, inDefaultValue, inIDispatch, outEnum, inBool, Date, + outDate, SafeArray, outSafeArray)+import qualified System.Win32.Com as Com (LIBID, mkLIBID, IID, mkIID, IUnknown)+import qualified Data.Int (Int32)++libidWindowsInstaller :: Com.LIBID+libidWindowsInstaller =+ Com.mkLIBID "{000C1092-0000-0000-C000-000000000046}"++-- --------------------------------------------------+-- +-- dispinterface UIPreview+-- +-- --------------------------------------------------+data UIPreview_ a = UIPreview__+ +type UIPreview a = Automation.IDispatch (UIPreview_ a)+iidUIPreview :: Com.IID (UIPreview ())+iidUIPreview = Com.mkIID "{000C109A-0000-0000-C000-000000000046}"++getProperty :: Prelude.String+ -> UIPreview a0+ -> Prelude.IO Prelude.String+getProperty name =+ Automation.propertyGet "Property"+ [Automation.inString name]+ Automation.outString++setProperty :: Prelude.String+ -> Prelude.String+ -> UIPreview a0+ -> Prelude.IO ()+setProperty name x0 =+ Automation.propertySet "Property"+ [ Automation.inString name+ , Automation.inString x0+ ]++viewDialog :: Prelude.String+ -> UIPreview a0+ -> Prelude.IO ()+viewDialog dialog =+ Automation.method0 "ViewDialog"+ [Automation.inString dialog]++viewBillboard :: Prelude.String+ -> Prelude.String+ -> UIPreview a0+ -> Prelude.IO ()+viewBillboard control billboard =+ Automation.method0 "ViewBillboard"+ [ Automation.inString control+ , Automation.inString billboard+ ]++-- --------------------------------------------------+-- +-- dispinterface SummaryInfo+-- +-- --------------------------------------------------+data SummaryInfo_ a = SummaryInfo__+ +type SummaryInfo a = Automation.IDispatch (SummaryInfo_ a)+iidSummaryInfo :: Com.IID (SummaryInfo ())+iidSummaryInfo = Com.mkIID "{000C109B-0000-0000-C000-000000000046}"++getProperty0 :: (Automation.Variant a1)+ => Data.Int.Int32+ -> SummaryInfo a0+ -> Prelude.IO a1+getProperty0 pid =+ Automation.propertyGet "Property"+ [Automation.inInt32 pid]+ Automation.outVariant++setProperty0 :: (Automation.Variant a1)+ => Data.Int.Int32+ -> a1+ -> SummaryInfo a0+ -> Prelude.IO ()+setProperty0 pid x0 =+ Automation.propertySet "Property"+ [ Automation.inInt32 pid+ , Automation.inVariant x0+ ]++getPropertyCount :: SummaryInfo a0+ -> Prelude.IO Data.Int.Int32+getPropertyCount =+ Automation.propertyGet "PropertyCount"+ []+ Automation.outInt32++persist :: SummaryInfo a0+ -> Prelude.IO ()+persist =+ Automation.method0 "Persist"+ []++-- --------------------------------------------------+-- +-- dispinterface StringList+-- +-- --------------------------------------------------+data StringList_ a = StringList__+ +type StringList a = Automation.IDispatch (StringList_ a)+iidStringList :: Com.IID (StringList ())+iidStringList = Com.mkIID "{000C1095-0000-0000-C000-000000000046}"++newEnum :: StringList a0+ -> Prelude.IO (Com.IUnknown ())+newEnum =+ Automation.function1 "_NewEnum"+ []+ Automation.outIUnknown++getItem :: Data.Int.Int32+ -> StringList a0+ -> Prelude.IO Prelude.String+getItem index =+ Automation.propertyGet "Item"+ [Automation.inInt32 index]+ Automation.outString++getCount :: StringList a0+ -> Prelude.IO Data.Int.Int32+getCount =+ Automation.propertyGet "Count"+ []+ Automation.outInt32++data MsiViewModify+ = MsiViewModifySeek+ | MsiViewModifyRefresh+ | MsiViewModifyInsert+ | MsiViewModifyUpdate+ | MsiViewModifyAssign+ | MsiViewModifyReplace+ | MsiViewModifyMerge+ | MsiViewModifyDelete+ | MsiViewModifyInsertTemporary+ | MsiViewModifyValidate+ | MsiViewModifyValidateNew+ | MsiViewModifyValidateField+ | MsiViewModifyValidateDelete+ +instance Prelude.Enum (MsiViewModify) where+ fromEnum v =+ case v of+ MsiViewModifySeek -> (-1)+ MsiViewModifyRefresh -> 0+ MsiViewModifyInsert -> 1+ MsiViewModifyUpdate -> 2+ MsiViewModifyAssign -> 3+ MsiViewModifyReplace -> 4+ MsiViewModifyMerge -> 5+ MsiViewModifyDelete -> 6+ MsiViewModifyInsertTemporary -> 7+ MsiViewModifyValidate -> 8+ MsiViewModifyValidateNew -> 9+ MsiViewModifyValidateField -> 10+ MsiViewModifyValidateDelete -> 11+ + toEnum v =+ case v of+ (-1) -> MsiViewModifySeek+ 0 -> MsiViewModifyRefresh+ 1 -> MsiViewModifyInsert+ 2 -> MsiViewModifyUpdate+ 3 -> MsiViewModifyAssign+ 4 -> MsiViewModifyReplace+ 5 -> MsiViewModifyMerge+ 6 -> MsiViewModifyDelete+ 7 -> MsiViewModifyInsertTemporary+ 8 -> MsiViewModifyValidate+ 9 -> MsiViewModifyValidateNew+ 10 -> MsiViewModifyValidateField+ 11 -> MsiViewModifyValidateDelete+ _ -> Prelude.error "unmarshallMsiViewModify: illegal enum value "+ +data MsiUILevel+ = MsiUILevelNoChange+ | MsiUILevelDefault+ | MsiUILevelNone+ | MsiUILevelBasic+ | MsiUILevelReduced+ | MsiUILevelFull+ | MsiUILevelHideCancel+ | MsiUILevelProgressOnly+ | MsiUILevelEndDialog+ +instance Prelude.Enum (MsiUILevel) where+ fromEnum v =+ case v of+ MsiUILevelNoChange -> 0+ MsiUILevelDefault -> 1+ MsiUILevelNone -> 2+ MsiUILevelBasic -> 3+ MsiUILevelReduced -> 4+ MsiUILevelFull -> 5+ MsiUILevelHideCancel -> 32+ MsiUILevelProgressOnly -> 64+ MsiUILevelEndDialog -> 128+ + toEnum v =+ case v of+ 0 -> MsiUILevelNoChange+ 1 -> MsiUILevelDefault+ 2 -> MsiUILevelNone+ 3 -> MsiUILevelBasic+ 4 -> MsiUILevelReduced+ 5 -> MsiUILevelFull+ 32 -> MsiUILevelHideCancel+ 64 -> MsiUILevelProgressOnly+ 128 -> MsiUILevelEndDialog+ _ -> Prelude.error "unmarshallMsiUILevel: illegal enum value "+ +data MsiTransformValidation+ = MsiTransformValidationNone+ | MsiTransformValidationLanguage+ | MsiTransformValidationProduct+ | MsiTransformValidationPlatform+ | MsiTransformValidationMajorVer+ | MsiTransformValidationMinorVer+ | MsiTransformValidationUpdateVer+ | MsiTransformValidationLess+ | MsiTransformValidationLessOrEqual+ | MsiTransformValidationEqual+ | MsiTransformValidationGreaterOrEqual+ | MsiTransformValidationGreater+ | MsiTransformValidationUpgradeCode+ +instance Prelude.Enum (MsiTransformValidation) where+ fromEnum v =+ case v of+ MsiTransformValidationNone -> 0+ MsiTransformValidationLanguage -> 1+ MsiTransformValidationProduct -> 2+ MsiTransformValidationPlatform -> 4+ MsiTransformValidationMajorVer -> 8+ MsiTransformValidationMinorVer -> 16+ MsiTransformValidationUpdateVer -> 32+ MsiTransformValidationLess -> 64+ MsiTransformValidationLessOrEqual -> 128+ MsiTransformValidationEqual -> 256+ MsiTransformValidationGreaterOrEqual -> 512+ MsiTransformValidationGreater -> 1024+ MsiTransformValidationUpgradeCode -> 2048+ + toEnum v =+ case v of+ 0 -> MsiTransformValidationNone+ 1 -> MsiTransformValidationLanguage+ 2 -> MsiTransformValidationProduct+ 4 -> MsiTransformValidationPlatform+ 8 -> MsiTransformValidationMajorVer+ 16 -> MsiTransformValidationMinorVer+ 32 -> MsiTransformValidationUpdateVer+ 64 -> MsiTransformValidationLess+ 128 -> MsiTransformValidationLessOrEqual+ 256 -> MsiTransformValidationEqual+ 512 -> MsiTransformValidationGreaterOrEqual+ 1024 -> MsiTransformValidationGreater+ 2048 -> MsiTransformValidationUpgradeCode+ _ -> Prelude.error "unmarshallMsiTransformValidation: illegal enum value "+ +data MsiTransformError+ = MsiTransformErrorNone+ | MsiTransformErrorAddExistingRow+ | MsiTransformErrorDeleteNonExistingRow+ | MsiTransformErrorAddExistingTable+ | MsiTransformErrorDeleteNonExistingTable+ | MsiTransformErrorUpdateNonExistingRow+ | MsiTransformErrorChangeCodePage+ | MsiTransformErrorViewTransform+ +instance Prelude.Enum (MsiTransformError) where+ fromEnum v =+ case v of+ MsiTransformErrorNone -> 0+ MsiTransformErrorAddExistingRow -> 1+ MsiTransformErrorDeleteNonExistingRow -> 2+ MsiTransformErrorAddExistingTable -> 4+ MsiTransformErrorDeleteNonExistingTable -> 8+ MsiTransformErrorUpdateNonExistingRow -> 16+ MsiTransformErrorChangeCodePage -> 32+ MsiTransformErrorViewTransform -> 256+ + toEnum v =+ case v of+ 0 -> MsiTransformErrorNone+ 1 -> MsiTransformErrorAddExistingRow+ 2 -> MsiTransformErrorDeleteNonExistingRow+ 4 -> MsiTransformErrorAddExistingTable+ 8 -> MsiTransformErrorDeleteNonExistingTable+ 16 -> MsiTransformErrorUpdateNonExistingRow+ 32 -> MsiTransformErrorChangeCodePage+ 256 -> MsiTransformErrorViewTransform+ _ -> Prelude.error "unmarshallMsiTransformError: illegal enum value "+ +data MsiSignatureOption = MsiSignatureOptionInvalidHashFatal+ +instance Prelude.Enum (MsiSignatureOption) where+ fromEnum v =+ case v of+ MsiSignatureOptionInvalidHashFatal -> 1+ + toEnum v =+ case v of+ 1 -> MsiSignatureOptionInvalidHashFatal+ _ -> Prelude.error "unmarshallMsiSignatureOption: illegal enum value "+ +data MsiSignatureInfo+ = MsiSignatureInfoCertificate+ | MsiSignatureInfoHash+ deriving (Prelude.Enum)+data MsiRunMode+ = MsiRunModeAdmin+ | MsiRunModeAdvertise+ | MsiRunModeMaintenance+ | MsiRunModeRollbackEnabled+ | MsiRunModeLogEnabled+ | MsiRunModeOperations+ | MsiRunModeRebootAtEnd+ | MsiRunModeRebootNow+ | MsiRunModeCabinet+ | MsiRunModeSourceShortNames+ | MsiRunModeTargetShortNames+ | MsiRunModeWindows9x+ | MsiRunModeZawEnabled+ | MsiRunModeScheduled+ | MsiRunModeRollback+ | MsiRunModeCommit+ +instance Prelude.Enum (MsiRunMode) where+ fromEnum v =+ case v of+ MsiRunModeAdmin -> 0+ MsiRunModeAdvertise -> 1+ MsiRunModeMaintenance -> 2+ MsiRunModeRollbackEnabled -> 3+ MsiRunModeLogEnabled -> 4+ MsiRunModeOperations -> 5+ MsiRunModeRebootAtEnd -> 6+ MsiRunModeRebootNow -> 7+ MsiRunModeCabinet -> 8+ MsiRunModeSourceShortNames -> 9+ MsiRunModeTargetShortNames -> 10+ MsiRunModeWindows9x -> 12+ MsiRunModeZawEnabled -> 13+ MsiRunModeScheduled -> 16+ MsiRunModeRollback -> 17+ MsiRunModeCommit -> 18+ + toEnum v =+ case v of+ 0 -> MsiRunModeAdmin+ 1 -> MsiRunModeAdvertise+ 2 -> MsiRunModeMaintenance+ 3 -> MsiRunModeRollbackEnabled+ 4 -> MsiRunModeLogEnabled+ 5 -> MsiRunModeOperations+ 6 -> MsiRunModeRebootAtEnd+ 7 -> MsiRunModeRebootNow+ 8 -> MsiRunModeCabinet+ 9 -> MsiRunModeSourceShortNames+ 10 -> MsiRunModeTargetShortNames+ 12 -> MsiRunModeWindows9x+ 13 -> MsiRunModeZawEnabled+ 16 -> MsiRunModeScheduled+ 17 -> MsiRunModeRollback+ 18 -> MsiRunModeCommit+ _ -> Prelude.error "unmarshallMsiRunMode: illegal enum value "+ +data MsiReinstallMode+ = MsiReinstallModeFileMissing+ | MsiReinstallModeFileOlderVersion+ | MsiReinstallModeFileEqualVersion+ | MsiReinstallModeFileExact+ | MsiReinstallModeFileVerify+ | MsiReinstallModeFileReplace+ | MsiReinstallModeMachineData+ | MsiReinstallModeUserData+ | MsiReinstallModeShortcut+ | MsiReinstallModePackage+ +instance Prelude.Enum (MsiReinstallMode) where+ fromEnum v =+ case v of+ MsiReinstallModeFileMissing -> 2+ MsiReinstallModeFileOlderVersion -> 4+ MsiReinstallModeFileEqualVersion -> 8+ MsiReinstallModeFileExact -> 16+ MsiReinstallModeFileVerify -> 32+ MsiReinstallModeFileReplace -> 64+ MsiReinstallModeMachineData -> 128+ MsiReinstallModeUserData -> 256+ MsiReinstallModeShortcut -> 512+ MsiReinstallModePackage -> 1024+ + toEnum v =+ case v of+ 2 -> MsiReinstallModeFileMissing+ 4 -> MsiReinstallModeFileOlderVersion+ 8 -> MsiReinstallModeFileEqualVersion+ 16 -> MsiReinstallModeFileExact+ 32 -> MsiReinstallModeFileVerify+ 64 -> MsiReinstallModeFileReplace+ 128 -> MsiReinstallModeMachineData+ 256 -> MsiReinstallModeUserData+ 512 -> MsiReinstallModeShortcut+ 1024 -> MsiReinstallModePackage+ _ -> Prelude.error "unmarshallMsiReinstallMode: illegal enum value "+ +data MsiReadStream+ = MsiReadStreamInteger+ | MsiReadStreamBytes+ | MsiReadStreamAnsi+ | MsiReadStreamDirect+ deriving (Prelude.Enum)+-- --------------------------------------------------+-- +-- dispinterface Record+-- +-- --------------------------------------------------+data Record_ a = Record__+ +type Record a = Automation.IDispatch (Record_ a)+iidRecord :: Com.IID (Record ())+iidRecord = Com.mkIID "{000C1093-0000-0000-C000-000000000046}"++getStringData :: Data.Int.Int32+ -> Record a0+ -> Prelude.IO Prelude.String+getStringData field =+ Automation.propertyGet "StringData"+ [Automation.inInt32 field]+ Automation.outString++setStringData :: Data.Int.Int32+ -> Prelude.String+ -> Record a0+ -> Prelude.IO ()+setStringData field x0 =+ Automation.propertySet "StringData"+ [ Automation.inInt32 field+ , Automation.inString x0+ ]++getIntegerData :: Data.Int.Int32+ -> Record a0+ -> Prelude.IO Data.Int.Int32+getIntegerData field =+ Automation.propertyGet "IntegerData"+ [Automation.inInt32 field]+ Automation.outInt32++setIntegerData :: Data.Int.Int32+ -> Data.Int.Int32+ -> Record a0+ -> Prelude.IO ()+setIntegerData field x0 =+ Automation.propertySet "IntegerData"+ [ Automation.inInt32 field+ , Automation.inInt32 x0+ ]++setStream :: Data.Int.Int32+ -> Prelude.String+ -> Record a0+ -> Prelude.IO ()+setStream field filePath =+ Automation.method0 "SetStream"+ [ Automation.inInt32 field+ , Automation.inString filePath+ ]++readStream :: Data.Int.Int32+ -> Data.Int.Int32+ -> MsiReadStream+ -> Record a0+ -> Prelude.IO Prelude.String+readStream field length format =+ Automation.function1 "ReadStream"+ [ Automation.inInt32 field+ , Automation.inInt32 length+ , Automation.inEnum format+ ]+ Automation.outString++getFieldCount :: Record a0+ -> Prelude.IO Data.Int.Int32+getFieldCount =+ Automation.propertyGet "FieldCount"+ []+ Automation.outInt32++getIsNull :: Data.Int.Int32+ -> Record a0+ -> Prelude.IO Prelude.Bool+getIsNull field =+ Automation.propertyGet "IsNull"+ [Automation.inInt32 field]+ Automation.outBool++getDataSize :: Data.Int.Int32+ -> Record a0+ -> Prelude.IO Data.Int.Int32+getDataSize field =+ Automation.propertyGet "DataSize"+ [Automation.inInt32 field]+ Automation.outInt32++clearData :: Record a0+ -> Prelude.IO ()+clearData =+ Automation.method0 "ClearData"+ []++formatText :: Record a0+ -> Prelude.IO Prelude.String+formatText =+ Automation.function1 "FormatText"+ []+ Automation.outString++-- --------------------------------------------------+-- +-- dispinterface RecordList+-- +-- --------------------------------------------------+data RecordList_ a = RecordList__+ +type RecordList a = Automation.IDispatch (RecordList_ a)+iidRecordList :: Com.IID (RecordList ())+iidRecordList = Com.mkIID "{000C1096-0000-0000-C000-000000000046}"++newEnum0 :: RecordList a0+ -> Prelude.IO (Com.IUnknown ())+newEnum0 =+ Automation.function1 "_NewEnum"+ []+ Automation.outIUnknown++getItem0 :: Data.Int.Int32+ -> RecordList a0+ -> Prelude.IO (Record ())+getItem0 index =+ Automation.propertyGet "Item"+ [Automation.inInt32 index]+ Automation.outIDispatch++getCount0 :: RecordList a0+ -> Prelude.IO Data.Int.Int32+getCount0 =+ Automation.propertyGet "Count"+ []+ Automation.outInt32++data MsiOpenDatabaseMode+ = MsiOpenDatabaseModeReadOnly+ | MsiOpenDatabaseModeTransact+ | MsiOpenDatabaseModeDirect+ | MsiOpenDatabaseModeCreate+ | MsiOpenDatabaseModeCreateDirect+ | MsiOpenDatabaseModePatchFile+ +instance Prelude.Enum (MsiOpenDatabaseMode) where+ fromEnum v =+ case v of+ MsiOpenDatabaseModeReadOnly -> 0+ MsiOpenDatabaseModeTransact -> 1+ MsiOpenDatabaseModeDirect -> 2+ MsiOpenDatabaseModeCreate -> 3+ MsiOpenDatabaseModeCreateDirect -> 4+ MsiOpenDatabaseModePatchFile -> 32+ + toEnum v =+ case v of+ 0 -> MsiOpenDatabaseModeReadOnly+ 1 -> MsiOpenDatabaseModeTransact+ 2 -> MsiOpenDatabaseModeDirect+ 3 -> MsiOpenDatabaseModeCreate+ 4 -> MsiOpenDatabaseModeCreateDirect+ 32 -> MsiOpenDatabaseModePatchFile+ _ -> Prelude.error "unmarshallMsiOpenDatabaseMode: illegal enum value "+ +data MsiMessageType+ = MsiMessageTypeFatalExit+ | MsiMessageTypeOk+ | MsiMessageTypeDefault1+ | MsiMessageTypeOkCancel+ | MsiMessageTypeAbortRetryIgnore+ | MsiMessageTypeYesNoCancel+ | MsiMessageTypeYesNo+ | MsiMessageTypeRetryCancel+ | MsiMessageTypeDefault2+ | MsiMessageTypeDefault3+ | MsiMessageTypeError+ | MsiMessageTypeWarning+ | MsiMessageTypeUser+ | MsiMessageTypeInfo+ | MsiMessageTypeFilesInUse+ | MsiMessageTypeResolveSource+ | MsiMessageTypeOutOfDiskSpace+ | MsiMessageTypeActionStart+ | MsiMessageTypeActionData+ | MsiMessageTypeProgress+ | MsiMessageTypeCommonData+ +instance Prelude.Enum (MsiMessageType) where+ fromEnum v =+ case v of+ MsiMessageTypeFatalExit -> 0+ MsiMessageTypeOk -> 0+ MsiMessageTypeDefault1 -> 0+ MsiMessageTypeOkCancel -> 1+ MsiMessageTypeAbortRetryIgnore -> 2+ MsiMessageTypeYesNoCancel -> 3+ MsiMessageTypeYesNo -> 4+ MsiMessageTypeRetryCancel -> 5+ MsiMessageTypeDefault2 -> 256+ MsiMessageTypeDefault3 -> 512+ MsiMessageTypeError -> 16777216+ MsiMessageTypeWarning -> 33554432+ MsiMessageTypeUser -> 50331648+ MsiMessageTypeInfo -> 67108864+ MsiMessageTypeFilesInUse -> 83886080+ MsiMessageTypeResolveSource -> 100663296+ MsiMessageTypeOutOfDiskSpace -> 117440512+ MsiMessageTypeActionStart -> 134217728+ MsiMessageTypeActionData -> 150994944+ MsiMessageTypeProgress -> 167772160+ MsiMessageTypeCommonData -> 184549376+ + toEnum v =+ case v of+ 0 -> MsiMessageTypeFatalExit+ 0 -> MsiMessageTypeOk+ 0 -> MsiMessageTypeDefault1+ 1 -> MsiMessageTypeOkCancel+ 2 -> MsiMessageTypeAbortRetryIgnore+ 3 -> MsiMessageTypeYesNoCancel+ 4 -> MsiMessageTypeYesNo+ 5 -> MsiMessageTypeRetryCancel+ 256 -> MsiMessageTypeDefault2+ 512 -> MsiMessageTypeDefault3+ 16777216 -> MsiMessageTypeError+ 33554432 -> MsiMessageTypeWarning+ 50331648 -> MsiMessageTypeUser+ 67108864 -> MsiMessageTypeInfo+ 83886080 -> MsiMessageTypeFilesInUse+ 100663296 -> MsiMessageTypeResolveSource+ 117440512 -> MsiMessageTypeOutOfDiskSpace+ 134217728 -> MsiMessageTypeActionStart+ 150994944 -> MsiMessageTypeActionData+ 167772160 -> MsiMessageTypeProgress+ 184549376 -> MsiMessageTypeCommonData+ _ -> Prelude.error "unmarshallMsiMessageType: illegal enum value "+ +data MsiMessageStatus+ = MsiMessageStatusError+ | MsiMessageStatusNone+ | MsiMessageStatusOk+ | MsiMessageStatusCancel+ | MsiMessageStatusAbort+ | MsiMessageStatusRetry+ | MsiMessageStatusIgnore+ | MsiMessageStatusYes+ | MsiMessageStatusNo+ +instance Prelude.Enum (MsiMessageStatus) where+ fromEnum v =+ case v of+ MsiMessageStatusError -> (-1)+ MsiMessageStatusNone -> 0+ MsiMessageStatusOk -> 1+ MsiMessageStatusCancel -> 2+ MsiMessageStatusAbort -> 3+ MsiMessageStatusRetry -> 4+ MsiMessageStatusIgnore -> 5+ MsiMessageStatusYes -> 6+ MsiMessageStatusNo -> 7+ + toEnum v =+ case v of+ (-1) -> MsiMessageStatusError+ 0 -> MsiMessageStatusNone+ 1 -> MsiMessageStatusOk+ 2 -> MsiMessageStatusCancel+ 3 -> MsiMessageStatusAbort+ 4 -> MsiMessageStatusRetry+ 5 -> MsiMessageStatusIgnore+ 6 -> MsiMessageStatusYes+ 7 -> MsiMessageStatusNo+ _ -> Prelude.error "unmarshallMsiMessageStatus: illegal enum value "+ +data MsiInstallType+ = MsiInstallTypeDefault+ | MsiInstallTypeNetworkImage+ deriving (Prelude.Enum)+data MsiInstallState+ = MsiInstallStateNotUsed+ | MsiInstallStateBadConfig+ | MsiInstallStateIncomplete+ | MsiInstallStateSourceAbsent+ | MsiInstallStateInvalidArg+ | MsiInstallStateUnknown+ | MsiInstallStateBroken+ | MsiInstallStateAdvertised+ | MsiInstallStateRemoved+ | MsiInstallStateAbsent+ | MsiInstallStateLocal+ | MsiInstallStateSource+ | MsiInstallStateDefault+ +instance Prelude.Enum (MsiInstallState) where+ fromEnum v =+ case v of+ MsiInstallStateNotUsed -> (-7)+ MsiInstallStateBadConfig -> (-6)+ MsiInstallStateIncomplete -> (-5)+ MsiInstallStateSourceAbsent -> (-4)+ MsiInstallStateInvalidArg -> (-2)+ MsiInstallStateUnknown -> (-1)+ MsiInstallStateBroken -> 0+ MsiInstallStateAdvertised -> 1+ MsiInstallStateRemoved -> 1+ MsiInstallStateAbsent -> 2+ MsiInstallStateLocal -> 3+ MsiInstallStateSource -> 4+ MsiInstallStateDefault -> 5+ + toEnum v =+ case v of+ (-7) -> MsiInstallStateNotUsed+ (-6) -> MsiInstallStateBadConfig+ (-5) -> MsiInstallStateIncomplete+ (-4) -> MsiInstallStateSourceAbsent+ (-2) -> MsiInstallStateInvalidArg+ (-1) -> MsiInstallStateUnknown+ 0 -> MsiInstallStateBroken+ 1 -> MsiInstallStateAdvertised+ 1 -> MsiInstallStateRemoved+ 2 -> MsiInstallStateAbsent+ 3 -> MsiInstallStateLocal+ 4 -> MsiInstallStateSource+ 5 -> MsiInstallStateDefault+ _ -> Prelude.error "unmarshallMsiInstallState: illegal enum value "+ +data MsiInstallMode+ = MsiInstallModeNoSourceResolution+ | MsiInstallModeNoDetection+ | MsiInstallModeExisting+ | MsiInstallModeDefault+ +instance Prelude.Enum (MsiInstallMode) where+ fromEnum v =+ case v of+ MsiInstallModeNoSourceResolution -> (-3)+ MsiInstallModeNoDetection -> (-2)+ MsiInstallModeExisting -> (-1)+ MsiInstallModeDefault -> 0+ + toEnum v =+ case v of+ (-3) -> MsiInstallModeNoSourceResolution+ (-2) -> MsiInstallModeNoDetection+ (-1) -> MsiInstallModeExisting+ 0 -> MsiInstallModeDefault+ _ -> Prelude.error "unmarshallMsiInstallMode: illegal enum value "+ +data MsiEvaluateCondition+ = MsiEvaluateConditionFalse+ | MsiEvaluateConditionTrue+ | MsiEvaluateConditionNone+ | MsiEvaluateConditionError+ deriving (Prelude.Enum)+data MsiDoActionStatus+ = MsiDoActionStatusNoAction+ | MsiDoActionStatusSuccess+ | MsiDoActionStatusUserExit+ | MsiDoActionStatusFailure+ | MsiDoActionStatusSuspend+ | MsiDoActionStatusFinished+ | MsiDoActionStatusWrongState+ | MsiDoActionStatusBadActionData+ deriving (Prelude.Enum)+data MsiDatabaseState+ = MsiDatabaseStateRead+ | MsiDatabaseStateWrite+ deriving (Prelude.Enum)+data MsiCostTree+ = MsiCostTreeSelfOnly+ | MsiCostTreeChildren+ | MsiCostTreeParents+ deriving (Prelude.Enum)+data MsiColumnInfo+ = MsiColumnInfoNames+ | MsiColumnInfoTypes+ deriving (Prelude.Enum)+-- --------------------------------------------------+-- +-- dispinterface View+-- +-- --------------------------------------------------+data View_ a = View__+ +type View a = Automation.IDispatch (View_ a)+iidView :: Com.IID (View ())+iidView = Com.mkIID "{000C109C-0000-0000-C000-000000000046}"++execute :: (Automation.Variant a1)+ => a1+ -> View a0+ -> Prelude.IO ()+execute params =+ Automation.method0 "Execute"+ [Automation.inDefaultValue (Automation.inInt32 0) Automation.inVariant params]++fetch :: View a0+ -> Prelude.IO (Record ())+fetch =+ Automation.function1 "Fetch"+ []+ Automation.outIDispatch++modify :: MsiViewModify+ -> Record a1+ -> View a0+ -> Prelude.IO ()+modify mode record =+ Automation.method0 "Modify"+ [ Automation.inEnum mode+ , Automation.inIDispatch record+ ]++getColumnInfo :: MsiColumnInfo+ -> View a0+ -> Prelude.IO (Record ())+getColumnInfo info =+ Automation.propertyGet "ColumnInfo"+ [Automation.inEnum info]+ Automation.outIDispatch++close :: View a0+ -> Prelude.IO ()+close =+ Automation.method0 "Close"+ []++getError :: View a0+ -> Prelude.IO Prelude.String+getError =+ Automation.function1 "GetError"+ []+ Automation.outString++-- --------------------------------------------------+-- +-- dispinterface FeatureInfo+-- +-- --------------------------------------------------+data FeatureInfo_ a = FeatureInfo__+ +type FeatureInfo a = Automation.IDispatch (FeatureInfo_ a)+iidFeatureInfo :: Com.IID (FeatureInfo ())+iidFeatureInfo = Com.mkIID "{000C109F-0000-0000-C000-000000000046}"++getAttributes :: FeatureInfo a0+ -> Prelude.IO Data.Int.Int32+getAttributes =+ Automation.propertyGet "Attributes"+ []+ Automation.outInt32++setAttributes :: Data.Int.Int32+ -> FeatureInfo a0+ -> Prelude.IO ()+setAttributes prop =+ Automation.propertySet "Attributes"+ [Automation.inInt32 prop]++getTitle :: FeatureInfo a0+ -> Prelude.IO Prelude.String+getTitle =+ Automation.propertyGet "Title"+ []+ Automation.outString++getDescription :: FeatureInfo a0+ -> Prelude.IO Prelude.String+getDescription =+ Automation.propertyGet "Description"+ []+ Automation.outString++-- --------------------------------------------------+-- +-- dispinterface Database+-- +-- --------------------------------------------------+data Database_ a = Database__+ +type Database a = Automation.IDispatch (Database_ a)+iidDatabase :: Com.IID (Database ())+iidDatabase = Com.mkIID "{000C109D-0000-0000-C000-000000000046}"++getDatabaseState :: Database a0+ -> Prelude.IO MsiDatabaseState+getDatabaseState =+ Automation.propertyGet "DatabaseState"+ []+ Automation.outEnum++getSummaryInformation :: (Automation.Variant a1)+ => a1+ -> Database a0+ -> Prelude.IO (SummaryInfo ())+getSummaryInformation updateCount =+ Automation.propertyGet "SummaryInformation"+ [Automation.inDefaultValue (Automation.inInt32 0) Automation.inVariant updateCount]+ Automation.outIDispatch++openView :: Prelude.String+ -> Database a0+ -> Prelude.IO (View ())+openView sql =+ Automation.function1 "OpenView"+ [Automation.inString sql]+ Automation.outIDispatch++commit :: Database a0+ -> Prelude.IO ()+commit =+ Automation.method0 "Commit"+ []++getPrimaryKeys :: Prelude.String+ -> Database a0+ -> Prelude.IO (Record ())+getPrimaryKeys table =+ Automation.propertyGet "PrimaryKeys"+ [Automation.inString table]+ Automation.outIDispatch++import0 :: Prelude.String+ -> Prelude.String+ -> Database a0+ -> Prelude.IO ()+import0 folder file =+ Automation.method0 "Import"+ [ Automation.inString folder+ , Automation.inString file+ ]++export :: Prelude.String+ -> Prelude.String+ -> Prelude.String+ -> Database a0+ -> Prelude.IO ()+export table folder file =+ Automation.method0 "Export"+ [ Automation.inString table+ , Automation.inString folder+ , Automation.inString file+ ]++merge :: (Automation.Variant a2)+ => Database a1+ -> a2+ -> Database a0+ -> Prelude.IO Prelude.Bool+merge database errorTable =+ Automation.function1 "Merge"+ [ Automation.inIDispatch database+ , Automation.inDefaultValue (Automation.inVariant "0") Automation.inVariant errorTable+ ]+ Automation.outBool++generateTransform :: (Automation.Variant a2)+ => Database a1+ -> a2+ -> Database a0+ -> Prelude.IO Prelude.Bool+generateTransform referenceDatabase transformFile =+ Automation.function1 "GenerateTransform"+ [ Automation.inIDispatch referenceDatabase+ , Automation.inDefaultValue (Automation.inVariant "0") Automation.inVariant transformFile+ ]+ Automation.outBool++applyTransform :: Prelude.String+ -> MsiTransformError+ -> Database a0+ -> Prelude.IO ()+applyTransform transformFile errorConditions =+ Automation.method0 "ApplyTransform"+ [ Automation.inString transformFile+ , Automation.inEnum errorConditions+ ]++enableUIPreview :: Database a0+ -> Prelude.IO (UIPreview ())+enableUIPreview =+ Automation.function1 "EnableUIPreview"+ []+ Automation.outIDispatch++getTablePersistent :: Prelude.String+ -> Database a0+ -> Prelude.IO MsiEvaluateCondition+getTablePersistent table =+ Automation.propertyGet "TablePersistent"+ [Automation.inString table]+ Automation.outEnum++createTransformSummaryInfo :: Database a1+ -> Prelude.String+ -> MsiTransformError+ -> MsiTransformValidation+ -> Database a0+ -> Prelude.IO ()+createTransformSummaryInfo referenceDatabase transformFile errorConditions validation =+ Automation.method0 "CreateTransformSummaryInfo"+ [ Automation.inIDispatch referenceDatabase+ , Automation.inString transformFile+ , Automation.inEnum errorConditions+ , Automation.inEnum validation+ ]++-- --------------------------------------------------+-- +-- dispinterface Session+-- +-- --------------------------------------------------+data Session_ a = Session__+ +type Session a = Automation.IDispatch (Session_ a)+iidSession :: Com.IID (Session ())+iidSession = Com.mkIID "{000C109E-0000-0000-C000-000000000046}"++getInstaller :: Session a0+ -> Prelude.IO (Installer ())+getInstaller =+ Automation.propertyGet "Installer"+ []+ Automation.outIUnknown++getProperty1 :: Prelude.String+ -> Session a0+ -> Prelude.IO Prelude.String+getProperty1 name =+ Automation.propertyGet "Property"+ [Automation.inString name]+ Automation.outString++setProperty1 :: Prelude.String+ -> Prelude.String+ -> Session a0+ -> Prelude.IO ()+setProperty1 name x0 =+ Automation.propertySet "Property"+ [ Automation.inString name+ , Automation.inString x0+ ]++getLanguage :: Session a0+ -> Prelude.IO Data.Int.Int32+getLanguage =+ Automation.propertyGet "Language"+ []+ Automation.outInt32++getMode :: MsiRunMode+ -> Session a0+ -> Prelude.IO Prelude.Bool+getMode flag =+ Automation.propertyGet "Mode"+ [Automation.inEnum flag]+ Automation.outBool++setMode :: MsiRunMode+ -> Prelude.Bool+ -> Session a0+ -> Prelude.IO ()+setMode flag x0 =+ Automation.propertySet "Mode"+ [ Automation.inEnum flag+ , Automation.inBool x0+ ]++getDatabase :: Session a0+ -> Prelude.IO (Database ())+getDatabase =+ Automation.propertyGet "Database"+ []+ Automation.outIDispatch++getSourcePath :: Prelude.String+ -> Session a0+ -> Prelude.IO Prelude.String+getSourcePath folder =+ Automation.propertyGet "SourcePath"+ [Automation.inString folder]+ Automation.outString++getTargetPath :: Prelude.String+ -> Session a0+ -> Prelude.IO Prelude.String+getTargetPath folder =+ Automation.propertyGet "TargetPath"+ [Automation.inString folder]+ Automation.outString++setTargetPath :: Prelude.String+ -> Prelude.String+ -> Session a0+ -> Prelude.IO ()+setTargetPath folder x0 =+ Automation.propertySet "TargetPath"+ [ Automation.inString folder+ , Automation.inString x0+ ]++doAction :: Prelude.String+ -> Session a0+ -> Prelude.IO MsiDoActionStatus+doAction action =+ Automation.function1 "DoAction"+ [Automation.inString action]+ Automation.outEnum++sequence :: (Automation.Variant a1)+ => Prelude.String+ -> a1+ -> Session a0+ -> Prelude.IO MsiDoActionStatus+sequence table mode =+ Automation.function1 "Sequence"+ [ Automation.inString table+ , Automation.inVariant mode+ ]+ Automation.outEnum++evaluateCondition :: Prelude.String+ -> Session a0+ -> Prelude.IO MsiEvaluateCondition+evaluateCondition expression =+ Automation.function1 "EvaluateCondition"+ [Automation.inString expression]+ Automation.outEnum++formatRecord :: Record a1+ -> Session a0+ -> Prelude.IO Prelude.String+formatRecord record =+ Automation.function1 "FormatRecord"+ [Automation.inIDispatch record]+ Automation.outString++message :: MsiMessageType+ -> Record a1+ -> Session a0+ -> Prelude.IO MsiMessageStatus+message kind record =+ Automation.function1 "Message"+ [ Automation.inEnum kind+ , Automation.inIDispatch record+ ]+ Automation.outEnum++getFeatureCurrentState :: Prelude.String+ -> Session a0+ -> Prelude.IO MsiInstallState+getFeatureCurrentState feature =+ Automation.propertyGet "FeatureCurrentState"+ [Automation.inString feature]+ Automation.outEnum++getFeatureRequestState :: Prelude.String+ -> Session a0+ -> Prelude.IO MsiInstallState+getFeatureRequestState feature =+ Automation.propertyGet "FeatureRequestState"+ [Automation.inString feature]+ Automation.outEnum++setFeatureRequestState :: Prelude.String+ -> MsiInstallState+ -> Session a0+ -> Prelude.IO ()+setFeatureRequestState feature x0 =+ Automation.propertySet "FeatureRequestState"+ [ Automation.inString feature+ , Automation.inEnum x0+ ]++getFeatureValidStates :: Prelude.String+ -> Session a0+ -> Prelude.IO Data.Int.Int32+getFeatureValidStates feature =+ Automation.propertyGet "FeatureValidStates"+ [Automation.inString feature]+ Automation.outInt32++getFeatureCost :: Prelude.String+ -> MsiCostTree+ -> MsiInstallState+ -> Session a0+ -> Prelude.IO Data.Int.Int32+getFeatureCost feature costTree state =+ Automation.propertyGet "FeatureCost"+ [ Automation.inString feature+ , Automation.inEnum costTree+ , Automation.inEnum state+ ]+ Automation.outInt32++getComponentCurrentState :: Prelude.String+ -> Session a0+ -> Prelude.IO MsiInstallState+getComponentCurrentState component =+ Automation.propertyGet "ComponentCurrentState"+ [Automation.inString component]+ Automation.outEnum++getComponentRequestState :: Prelude.String+ -> Session a0+ -> Prelude.IO MsiInstallState+getComponentRequestState component =+ Automation.propertyGet "ComponentRequestState"+ [Automation.inString component]+ Automation.outEnum++setComponentRequestState :: Prelude.String+ -> MsiInstallState+ -> Session a0+ -> Prelude.IO ()+setComponentRequestState component x0 =+ Automation.propertySet "ComponentRequestState"+ [ Automation.inString component+ , Automation.inEnum x0+ ]++setInstallLevel :: Data.Int.Int32+ -> Session a0+ -> Prelude.IO ()+setInstallLevel level =+ Automation.method0 "SetInstallLevel"+ [Automation.inInt32 level]++getVerifyDiskSpace :: Session a0+ -> Prelude.IO Prelude.Bool+getVerifyDiskSpace =+ Automation.propertyGet "VerifyDiskSpace"+ []+ Automation.outBool++getProductProperty :: Prelude.String+ -> Session a0+ -> Prelude.IO Prelude.String+getProductProperty property =+ Automation.propertyGet "ProductProperty"+ [Automation.inString property]+ Automation.outString++getFeatureInfo :: Prelude.String+ -> Session a0+ -> Prelude.IO (FeatureInfo ())+getFeatureInfo feature =+ Automation.propertyGet "FeatureInfo"+ [Automation.inString feature]+ Automation.outIDispatch++getComponentCosts :: Prelude.String+ -> MsiInstallState+ -> Session a0+ -> Prelude.IO (RecordList ())+getComponentCosts component state =+ Automation.propertyGet "ComponentCosts"+ [ Automation.inString component+ , Automation.inEnum state+ ]+ Automation.outIDispatch++-- --------------------------------------------------+-- +-- dispinterface Installer+-- +-- --------------------------------------------------+data Installer_ a = Installer__+ +type Installer a = Automation.IDispatch (Installer_ a)+iidInstaller :: Com.IID (Installer ())+iidInstaller = Com.mkIID "{000C1090-0000-0000-C000-000000000046}"++getUILevel :: Installer a0+ -> Prelude.IO MsiUILevel+getUILevel =+ Automation.propertyGet "UILevel"+ []+ Automation.outEnum++setUILevel :: MsiUILevel+ -> Installer a0+ -> Prelude.IO ()+setUILevel prop =+ Automation.propertySet "UILevel"+ [Automation.inEnum prop]++createRecord :: Data.Int.Int32+ -> Installer a0+ -> Prelude.IO (Record ())+createRecord count =+ Automation.function1 "CreateRecord"+ [Automation.inInt32 count]+ Automation.outIDispatch++openPackage :: (Automation.Variant a1)+ => a1+ -> Installer a0+ -> Prelude.IO (Session ())+openPackage packagePath =+ Automation.function1 "OpenPackage"+ [Automation.inVariant packagePath]+ Automation.outIDispatch++openProduct :: Prelude.String+ -> Installer a0+ -> Prelude.IO (Session ())+openProduct productCode =+ Automation.function1 "OpenProduct"+ [Automation.inString productCode]+ Automation.outIDispatch++openDatabase :: (Automation.Variant a1)+ => Prelude.String+ -> a1+ -> Installer a0+ -> Prelude.IO (Database ())+openDatabase databasePath openMode =+ Automation.function1 "OpenDatabase"+ [ Automation.inString databasePath+ , Automation.inVariant openMode+ ]+ Automation.outIDispatch++getSummaryInformation0 :: (Automation.Variant a1)+ => Prelude.String+ -> a1+ -> Installer a0+ -> Prelude.IO (SummaryInfo ())+getSummaryInformation0 packagePath updateCount =+ Automation.propertyGet "SummaryInformation"+ [ Automation.inString packagePath+ , Automation.inDefaultValue (Automation.inInt32 0) Automation.inVariant updateCount+ ]+ Automation.outIDispatch++enableLog :: Prelude.String+ -> Prelude.String+ -> Installer a0+ -> Prelude.IO ()+enableLog logMode logFile =+ Automation.method0 "EnableLog"+ [ Automation.inString logMode+ , Automation.inString logFile+ ]++installProduct :: (Automation.Variant a1)+ => Prelude.String+ -> a1+ -> Installer a0+ -> Prelude.IO ()+installProduct packagePath propertyValues =+ Automation.method0 "InstallProduct"+ [ Automation.inString packagePath+ , Automation.inDefaultValue (Automation.inVariant "0") Automation.inVariant propertyValues+ ]++getVersion :: Installer a0+ -> Prelude.IO Prelude.String+getVersion =+ Automation.propertyGet "Version"+ []+ Automation.outString++lastErrorRecord :: Installer a0+ -> Prelude.IO (Record ())+lastErrorRecord =+{- ToDo: look into why this was mis-classified as a function.+ Automation.function1 "LastErrorRecord"+ []+ Automation.outIDispatch+-}+ Automation.propertyGet "LastErrorRecord"+ []+ Automation.outIDispatch++registryValue :: (Automation.Variant a1, Automation.Variant a2)+ => a1+ -> Prelude.String+ -> a2+ -> Installer a0+ -> Prelude.IO Prelude.String+registryValue root key value =+ Automation.function1 "RegistryValue"+ [ Automation.inVariant root+ , Automation.inString key+ , Automation.inVariant value+ ]+ Automation.outString++fileAttributes :: Prelude.String+ -> Installer a0+ -> Prelude.IO Data.Int.Int32+fileAttributes filePath =+ Automation.function1 "FileAttributes"+ [Automation.inString filePath]+ Automation.outInt32++fileSize :: Prelude.String+ -> Installer a0+ -> Prelude.IO Data.Int.Int32+fileSize filePath =+ Automation.function1 "FileSize"+ [Automation.inString filePath]+ Automation.outInt32++fileVersion :: (Automation.Variant a1)+ => Prelude.String+ -> a1+ -> Installer a0+ -> Prelude.IO Prelude.String+fileVersion filePath language =+ Automation.function1 "FileVersion"+ [ Automation.inString filePath+ , Automation.inVariant language+ ]+ Automation.outString++getEnvironment :: Prelude.String+ -> Installer a0+ -> Prelude.IO Prelude.String+getEnvironment variable =+ Automation.propertyGet "Environment"+ [Automation.inString variable]+ Automation.outString++setEnvironment :: Prelude.String+ -> Prelude.String+ -> Installer a0+ -> Prelude.IO ()+setEnvironment variable x0 =+ Automation.propertySet "Environment"+ [ Automation.inString variable+ , Automation.inString x0+ ]++getProductState :: Prelude.String+ -> Installer a0+ -> Prelude.IO MsiInstallState+getProductState product =+ Automation.propertyGet "ProductState"+ [Automation.inString product]+ Automation.outEnum++getProductInfo :: Prelude.String+ -> Prelude.String+ -> Installer a0+ -> Prelude.IO Prelude.String+getProductInfo product attribute =+ Automation.propertyGet "ProductInfo"+ [ Automation.inString product+ , Automation.inString attribute+ ]+ Automation.outString++configureProduct :: Prelude.String+ -> Data.Int.Int32+ -> MsiInstallState+ -> Installer a0+ -> Prelude.IO ()+configureProduct product installLevel installState =+ Automation.method0 "ConfigureProduct"+ [ Automation.inString product+ , Automation.inInt32 installLevel+ , Automation.inEnum installState+ ]++reinstallProduct :: Prelude.String+ -> MsiReinstallMode+ -> Installer a0+ -> Prelude.IO ()+reinstallProduct product reinstallMode =+ Automation.method0 "ReinstallProduct"+ [ Automation.inString product+ , Automation.inEnum reinstallMode+ ]++collectUserInfo :: Prelude.String+ -> Installer a0+ -> Prelude.IO ()+collectUserInfo product =+ Automation.method0 "CollectUserInfo"+ [Automation.inString product]++applyPatch :: Prelude.String+ -> Prelude.String+ -> MsiInstallType+ -> Prelude.String+ -> Installer a0+ -> Prelude.IO ()+applyPatch patchPackage installPackage installType commandLine =+ Automation.method0 "ApplyPatch"+ [ Automation.inString patchPackage+ , Automation.inString installPackage+ , Automation.inEnum installType+ , Automation.inString commandLine+ ]++getFeatureParent :: Prelude.String+ -> Prelude.String+ -> Installer a0+ -> Prelude.IO Prelude.String+getFeatureParent product feature =+ Automation.propertyGet "FeatureParent"+ [ Automation.inString product+ , Automation.inString feature+ ]+ Automation.outString++getFeatureState :: Prelude.String+ -> Prelude.String+ -> Installer a0+ -> Prelude.IO MsiInstallState+getFeatureState product feature =+ Automation.propertyGet "FeatureState"+ [ Automation.inString product+ , Automation.inString feature+ ]+ Automation.outEnum++useFeature :: Prelude.String+ -> Prelude.String+ -> MsiInstallMode+ -> Installer a0+ -> Prelude.IO ()+useFeature product feature installMode =+ Automation.method0 "UseFeature"+ [ Automation.inString product+ , Automation.inString feature+ , Automation.inEnum installMode+ ]++getFeatureUsageCount :: Prelude.String+ -> Prelude.String+ -> Installer a0+ -> Prelude.IO Data.Int.Int32+getFeatureUsageCount product feature =+ Automation.propertyGet "FeatureUsageCount"+ [ Automation.inString product+ , Automation.inString feature+ ]+ Automation.outInt32++getFeatureUsageDate :: Prelude.String+ -> Prelude.String+ -> Installer a0+ -> Prelude.IO Automation.Date+getFeatureUsageDate product feature =+ Automation.propertyGet "FeatureUsageDate"+ [ Automation.inString product+ , Automation.inString feature+ ]+ Automation.outDate++configureFeature :: Prelude.String+ -> Prelude.String+ -> MsiInstallState+ -> Installer a0+ -> Prelude.IO ()+configureFeature product feature installState =+ Automation.method0 "ConfigureFeature"+ [ Automation.inString product+ , Automation.inString feature+ , Automation.inEnum installState+ ]++reinstallFeature :: Prelude.String+ -> Prelude.String+ -> MsiReinstallMode+ -> Installer a0+ -> Prelude.IO ()+reinstallFeature product feature reinstallMode =+ Automation.method0 "ReinstallFeature"+ [ Automation.inString product+ , Automation.inString feature+ , Automation.inEnum reinstallMode+ ]++provideComponent :: Prelude.String+ -> Prelude.String+ -> Prelude.String+ -> Data.Int.Int32+ -> Installer a0+ -> Prelude.IO Prelude.String+provideComponent product feature component installMode =+ Automation.function1 "ProvideComponent"+ [ Automation.inString product+ , Automation.inString feature+ , Automation.inString component+ , Automation.inInt32 installMode+ ]+ Automation.outString++getComponentPath :: Prelude.String+ -> Prelude.String+ -> Installer a0+ -> Prelude.IO Prelude.String+getComponentPath product component =+ Automation.propertyGet "ComponentPath"+ [ Automation.inString product+ , Automation.inString component+ ]+ Automation.outString++provideQualifiedComponent :: Prelude.String+ -> Prelude.String+ -> Data.Int.Int32+ -> Installer a0+ -> Prelude.IO Prelude.String+provideQualifiedComponent category qualifier installMode =+ Automation.function1 "ProvideQualifiedComponent"+ [ Automation.inString category+ , Automation.inString qualifier+ , Automation.inInt32 installMode+ ]+ Automation.outString++getQualifierDescription :: Prelude.String+ -> Prelude.String+ -> Installer a0+ -> Prelude.IO Prelude.String+getQualifierDescription category qualifier =+ Automation.propertyGet "QualifierDescription"+ [ Automation.inString category+ , Automation.inString qualifier+ ]+ Automation.outString++getComponentQualifiers :: Prelude.String+ -> Installer a0+ -> Prelude.IO (StringList ())+getComponentQualifiers category =+ Automation.propertyGet "ComponentQualifiers"+ [Automation.inString category]+ Automation.outIDispatch++getProducts :: Installer a0+ -> Prelude.IO (StringList ())+getProducts =+ Automation.propertyGet "Products"+ []+ Automation.outIDispatch++getFeatures :: Prelude.String+ -> Installer a0+ -> Prelude.IO (StringList ())+getFeatures product =+ Automation.propertyGet "Features"+ [Automation.inString product]+ Automation.outIDispatch++getComponents :: Installer a0+ -> Prelude.IO (StringList ())+getComponents =+ Automation.propertyGet "Components"+ []+ Automation.outIDispatch++getComponentClients :: Prelude.String+ -> Installer a0+ -> Prelude.IO (StringList ())+getComponentClients component =+ Automation.propertyGet "ComponentClients"+ [Automation.inString component]+ Automation.outIDispatch++getPatches :: Prelude.String+ -> Installer a0+ -> Prelude.IO (StringList ())+getPatches product =+ Automation.propertyGet "Patches"+ [Automation.inString product]+ Automation.outIDispatch++getRelatedProducts :: Prelude.String+ -> Installer a0+ -> Prelude.IO (StringList ())+getRelatedProducts upgradeCode =+ Automation.propertyGet "RelatedProducts"+ [Automation.inString upgradeCode]+ Automation.outIDispatch++getPatchInfo :: Prelude.String+ -> Prelude.String+ -> Installer a0+ -> Prelude.IO Prelude.String+getPatchInfo patch attribute =+ Automation.propertyGet "PatchInfo"+ [ Automation.inString patch+ , Automation.inString attribute+ ]+ Automation.outString++getPatchTransforms :: Prelude.String+ -> Prelude.String+ -> Installer a0+ -> Prelude.IO Prelude.String+getPatchTransforms product patch =+ Automation.propertyGet "PatchTransforms"+ [ Automation.inString product+ , Automation.inString patch+ ]+ Automation.outString++addSource :: Prelude.String+ -> Prelude.String+ -> Prelude.String+ -> Installer a0+ -> Prelude.IO ()+addSource product user source =+ Automation.method0 "AddSource"+ [ Automation.inString product+ , Automation.inString user+ , Automation.inString source+ ]++clearSourceList :: Prelude.String+ -> Prelude.String+ -> Installer a0+ -> Prelude.IO ()+clearSourceList product user =+ Automation.method0 "ClearSourceList"+ [ Automation.inString product+ , Automation.inString user+ ]++forceSourceListResolution :: Prelude.String+ -> Prelude.String+ -> Installer a0+ -> Prelude.IO ()+forceSourceListResolution product user =+ Automation.method0 "ForceSourceListResolution"+ [ Automation.inString product+ , Automation.inString user+ ]++getGetShortcutTarget :: Prelude.String+ -> Installer a0+ -> Prelude.IO (Record ())+getGetShortcutTarget shortcutPath =+ Automation.propertyGet "GetShortcutTarget"+ [Automation.inString shortcutPath]+ Automation.outIDispatch++fileHash :: Prelude.String+ -> Data.Int.Int32+ -> Installer a0+ -> Prelude.IO (Record ())+fileHash filePath options =+ Automation.function1 "FileHash"+ [ Automation.inString filePath+ , Automation.inInt32 options+ ]+ Automation.outIDispatch++fileSignatureInfo :: Prelude.String+ -> Data.Int.Int32+ -> MsiSignatureInfo+ -> Installer a0+ -> Prelude.IO (Automation.SafeArray Prelude.Char)+fileSignatureInfo filePath options format =+ Automation.function1 "FileSignatureInfo"+ [ Automation.inString filePath+ , Automation.inInt32 options+ , Automation.inEnum format+ ]+ Automation.outSafeArray++data Constants = MsiDatabaseNullInteger+ +instance Prelude.Enum (Constants) where+ fromEnum v =+ case v of+ MsiDatabaseNullInteger -> (-2147483648)+ + toEnum v =+ case v of+ (-2147483648) -> MsiDatabaseNullInteger+ _ -> Prelude.error "unmarshallConstants: illegal enum value "+ +
+ Bamse/Writer.hs view
@@ -0,0 +1,702 @@+--+-- (c) 2007, Galois, Inc.+--+-- Outputting an MSI database.+-- +module Bamse.Writer (+ outputMSI -- :: WriterEnv {- env (file to output to, etc.) -}+ -- -> Package {- specification of package -}+ -- -> FilePath {- directory where the package's + -- files are rooted -}+ -- -> [Table] {- tables that need to be created -}+ -- -> [(TableName, [Row])] + {- data to populate the tables with -}+ -- -> [ReplaceRow] {- rows to replace in the base package -}+ -- -> IO ()+ , getProductCodes+ ) where++import qualified Prelude+import Prelude++import Bamse.MSITable+import Bamse.MSIExtra+import Bamse.Package++import Data.List +import Control.Monad+import System ( system, ExitCode(..) )+import Time ( getClockTime )+import Data.Maybe ( fromMaybe, mapMaybe )+import Directory ( removeFile, doesFileExist )+import System.IO+import Data.Char ( toUpper )+import Data.Int ( Int32 )+import Data.Bits++import Util.List ( mapFirstDefault, enclose )++import System.Win32.Com.Automation+ ( (#), coRun, coCreateObject, + isCoError, coGetErrorString,+ isNullInterface, + Date, clockTimeToDate )+import Bamse.WindowsInstaller hiding ( sequence )+import Debug.Trace ( trace )++{-+ Module: Writer+ + Purpose:+ this module serialises an MS Installer package. An installer is+ a database containing a number of tables describing what's supposed+ to happen when the installer is run (to install / un-install the+ package). We construct the database from the table data specified+ in Haskell together with meta-data describing the package itself.+ + Comments:+ The only export from this module is 'outputMSI' which coordinates+ the steps involved in creating an MSI installer:+ + * creates base package (from external files).+ * adds meta data describing package/installer.+ * fills in the database tables making up the installer.+ * (optionally) compress the MSI by running 'makecab'.+ + ToDo:+ let you create a web-based installer.+-}++--+-- Function: outputMSI+--+-- Purpose: create a complete MSI installer given a set of +-- database rows and meta information describing+-- the package.+--+outputMSI :: WriterEnv+ -> [Table]+ -> [(TableName, [Row])]+ -> [ReplaceRow]+ -> IO ()+outputMSI env tables rows repls = do+ -- ToDo: internalise (some/all) of the data contained+ -- in these SDK-provided .msi templates.+ let package = w_package env+ let pkg = p_pkgInfo package+ putStr "Creating base package..."+ createBasePackage (w_toolDir env) (w_templateDir env) (w_outFile env)+ putStrLn "done."+ ip <- coCreateObject "WindowsInstaller.Installer" iidInstaller+ flip catch (topHandler ip) $ do+ putStr "Creating MSI tables.."+ db <- ip # openDatabase (w_outFile env) (fromEnum MsiOpenDatabaseModeTransact)+ db # createTables tables+ putStrLn "done."+ putStr "Writing out package data..."+ db # writePackageInfo pkg (p_productGUID package) (p_revisionGUID package) ip+ putStrLn "done."+ putStr "Tidying up tables..."+ db # storeTables tables rows ip+ db # replaceRows repls+ putStrLn "done."+ putStrLn "Compressing installer contents.."+ hFlush stdout+ ip # makeCab (w_outFile env) (w_srcDir env) db+ db # commit+ putStrLn "All done!"+ return ()++--+-- Function: getProductCodes+--+-- Purpose: Fetch the product and revision GUIDs from an MSI.+-- Use this when we're updating/re-generating an installer.+--+getProductCodes :: FilePath -> IO (String, String)+getProductCodes oFile = coRun $ do+ flg <- doesFileExist oFile+ when (not flg)+ (ioError (userError ("Unable to locate: " ++ oFile)))+ ip <- coCreateObject "WindowsInstaller.Installer" iidInstaller+ flip catch (topHandler ip) $ do+ db <- ip # openDatabase oFile (fromEnum MsiOpenDatabaseModeReadOnly)+ (rec,_) <- db # fetchRow "Property"+ [ ("Property", "ProductCode") ]+ [ ("Value", Nothing) ]+ prodC <- rec # getStringData 1+ si <- db # getSummaryInformation (1::Int32)+ revC <- si # getProperty0 (fromIntegral $ fromEnum PID_REVNUMBER)+ return (prodC, revC)++topHandler ip err + | isCoError err = flip catch (\ e -> ioError e) $ do+ let v = coGetErrorString err+ rec <- ip # lastErrorRecord+ len <- rec # getFieldCount+ ls <- mapM (\ i -> rec # getStringData i)+ [1 .. len]+ ioError (userError (v ++ + unlines (("\nDetails (first val is the error code): ") : map (" "++) ls)))+ | otherwise = ioError err++--+-- Function: storeTables+--+storeTables :: [Table]+ -> [(TableName, [Row])]+ -> Installer a+ -> Database b+ -> IO ()+storeTables tables rows ip db = mapM_ (writeTable ip db tables) augmented_rows+ where+ augmented_rows = commonUpTables $ + mapMaybe toRowData $+ foldl addRow rows default_rows+ + -- reduce the number of table views we have to perform by+ -- commoning up entries with the same table name.+ commonUpTables ts = + map (\ ls@((tnm,sz,_):_) -> (tnm, sz, concatMap (\ (_,_,xs) -> xs) ls)) $+ groupBy (\ (t1,_,_) (t2,_,_) -> t1 == t2) ts++ toRowData (tnm, rows) = + case lookup tnm tables of+ Just cols+ -> Just ( tnm+ , length cols+ , map (\ (tnm, vals) -> mapMaybe (toIdx tnm cols) vals) rows+ )+ Nothing -> trace ("storeTables: WARNING: unknown table " ++ tnm) $+ Nothing+ + toIdx _ _cols (_, Nothing) = Nothing+ toIdx tabNm cols (nm, Just v) = + case findIndex (\ (n,_) -> n == nm) cols of+ Just x -> Just (x+1, v)+ Nothing -> trace ("storeTable.toIdx: WARNING: unknown column " ++ + show (nm,tabNm)) $+ Nothing++ addRow rows row@(tn,_) = mapFirstDefault (tn,[row]) (f row) rows+ where+ f tab@(tnm,_) (tn,rs2) + | tn == tnm = Just (tnm, tab : rs2)+ | otherwise = Nothing+ + -- currently assume that the tables passed+ -- in aren't 100% complete. (This isn't a good+ -- place to store this extra table data tho.)+ default_rows =+ [ ( "Directory"+ , [ "Directory" -=> Just (string "TARGETDIR")+ , "DefaultDir" -=> Just (string "SourceDir")+ ]+ )+ , ( "Media"+ , [ "DiskId" -=> Just (int 1)+ , "LastSequence" -=> Just (int 1)+ , "DiskPrompt" -=> Just (string "")+ , "Cabinet" -=> Just (string "")+ , "VolumeLabel" -=> Just (string "")+ , "Source" -=> Just (string "")+ ]+ )+ ]++writeTable :: Installer a+ -> Database b+ -> [Table]+ -> (TableName, Int, [RowData])+ -> IO ()+writeTable ip db tables (nm, sz, rows) = do+ view <-+ case insertRowSql tables nm of+ Just query -> db # openView query+ Nothing -> do+ hPutStrLn stderr ("WARNING: unknown/new table " ++ nm)+ hFlush stderr+ case lookup nm tables of+ Nothing -> ioError (userError $ "Unknown table: " ++ nm)+ Just t -> do+ db # newTable (nm,t)+ case (insertRowSql tables nm) of+ Nothing -> ioError (userError $ "Unknown table: " ++ nm)+ Just q -> db # openView q+ mapM_ (writeRow view) rows+ view # close+ return ()+ where+ writeRow view idx_vals = do+ rec <- ip # createRecord (fromIntegral sz)+ mapM_ (writeValue rec) idx_vals+ catch (view # execute rec)+ (\ err -> print (nm, insertRowSql tables nm, idx_vals) >> ioError err)+ return ()++ writeValue rec (idx_i, v) = + case v of+ String s -> rec # setStringData idx s+ Int i -> rec # setIntegerData idx (fromIntegral i)+ Long l -> rec # setIntegerData idx (fromIntegral l)+ File f -> catch+ (rec # setStream idx f)+ (\ ioe -> do+ hPutStrLn stderr ("Unable to store file: " ++ show f)+ ioError ioe)+ where+ idx :: Int32+ idx = fromIntegral idx_i++insertRowSql :: [Table]+ -> TableName+ -> Maybe String+insertRowSql tables tabNm =+ case lookup tabNm tables of+ Nothing -> Nothing+ Just cols -> Just $+ unwords [ "INSERT INTO"+ , backTick tabNm+ , inParen $ concat (intersperse "," field_labels)+ , "VALUES"+ , inParen $ concat (intersperse "," field_values)+ ]+ where+ field_labels = map backTick field_labs+ + (field_labs, field_values) = unzip (map toFields cols)++ toFields (nm, cVal) = + ( nm+ , case cVal of + (_,True,_) -> "?"+ (True,_,_) -> "?"+ (False,_,_) -> "?"+ )++backTick :: String -> String+backTick s = enclose "`" "`" s+fwdTick :: String -> String+fwdTick s = enclose "'" "'" s+inParen :: String -> String+inParen s = enclose "(" ")" s++--+-- Function: writePackageInfo+--+-- Purpose: emit standard package info into new MSI database.+--+writePackageInfo :: Package+ -> String+ -> String+ -> Installer a+ -> Database b+ -> IO ()+writePackageInfo pkg pguid rguid ip db = do+ db # setSummaryInformation + [ (PID_TITLE, title pkg)+ , (PID_SUBJECT, name pkg)+ , (PID_AUTHOR, author pkg)+ , (PID_COMMENTS, comment pkg)+ , (PID_REVNUMBER, map toUpper rguid)+ , (PID_APPNAME, name pkg)+ ]+ view <- db # openMSITable "Property"+ mapM_ (setPair ip view) + [ ("ProductCode", map toUpper pguid)+ , ("ProductName", title pkg)+-- Don't hardwire the language.+-- , ("ProductLanguage", "1033")+ , ("ProductVersion", productVersion pkg)+ , ("Manufacturer", author pkg)+-- plumb package URL to here+-- , ("ARPURLINFOABOUT", webSite)+ ]+ view # close+ return ()++setPair :: Installer a+ -> View b+ -> (String,String)+ -> IO ()+setPair inst view (name,val) = do+ rec <- inst # createRecord 2+ rec # setStringData 1 name+ rec # setStringData 2 val+ catch (view # execute rec)+ (\ e -> putStrLn ("setPair failed: " ++ name) >> ioError e)+ return ()++setSummaryInformation :: [(ProductIDTag, String)]+ -> Database a+ -> IO ()+setSummaryInformation info db = do+ si <- db # getSummaryInformation (length info + 3)+ Prelude.sequence (map (setProp si) info)+ x <- getClockTime+ d <- clockTimeToDate x+ setProp si (PID_LASTPRINTED, d)+ setProp si (PID_CREATE_DTM, d)+ setProp si (PID_LASTSAVE_DTM, d)+ si # persist+ return ()+ where+ setProp si (pid, val) = do+ si # setProperty0 (fromEnum32 pid) val++ fromEnum32 :: Enum a => a -> Int32+ fromEnum32 = fromIntegral . Prelude.fromEnum+++--+-- Function: openMSITable+--+-- Purpose: open up a standard MSI table for insertion.+-- +openMSITable :: TableName+ -> Database a+ -> IO (View ())+openMSITable tabName db = do+ case (insertRowSql msiTables tabName) of+ Nothing -> ioError (userError ("openMISTable: Unknown table -- " ++ tabName))+ Just q -> db # openView q++--+-- Function: createTables+--+-- Purpose: given a set of tables, create those that+-- aren't already present in an MSI database.+--+createTables :: [Table]+ -> Database a+ -> IO ()+createTables tabs db = do+ notTheres <- filterM isPresent tabs+ mapM_ (\ t -> catch (db # newTable t) + (const (return ())))+ notTheres+ where+ isPresent (tNm, _) = catch+ (do+ rc <- db # getTablePersistent tNm+ case rc of+ MsiEvaluateConditionFalse -> return False+ MsiEvaluateConditionTrue -> return False+ MsiEvaluateConditionNone -> return True+ MsiEvaluateConditionError -> return True+ )+ (\ _ -> return True)++--+-- Function: createBasePackage+--+-- Purpose: Output a standard and minimal MSI database+-- to a file. Combines three MSI SDK-provided+-- files to do this, including one containing+-- a collection of user interface dialogs.+-- Comment: to avoid having to redo this everytime, the+-- three MSIs have been merged already, so we+-- just copy that single file (base.msi) instead.+-- +createBasePackage :: FilePath -> FilePath -> FilePath -> IO ()+createBasePackage bamseDir tDir dest = + copyFile (tDir ++ "\\base.msi") dest+{-was:+ copyFile (src ++ "\\Schema.msi") dest+ mergePackage src dest "Sequence.msi"+ mergePackage src dest "UISample.msi"+-}++copyFile :: String -> String -> IO ()+copyFile src dest = do+ rc <- system ("copy /b \"" ++ src ++ '"':' ':'"':dest ++ "\" > nul")+ case rc of+ ExitSuccess{} -> return ()+ _ -> putStrLn $ "ERROR: Unable to copy " ++ show src ++ " to " ++ show dest++mergePackage :: String+ -> String+ -> String+ -> Installer a+ -> IO ()+mergePackage src dest db ip = do+ db1 <- ip # openDatabase src (fromEnum MsiOpenDatabaseModeTransact)+ db2 <- ip # openDatabase dest (fromEnum MsiOpenDatabaseModeReadOnly)+ let errorTable = "_MergeErrors"+ flg <- db1 # merge db2 errorTable+ when (not flg)+ (hPutStrLn stderr+ (unlines [ "Merging"+ , src+ , "with"+ , dest+ , "ran into trouble, see"+ , errorTable+ , "table for details"+ ]))+ -- don't follow the MSI SDK's WiMerge.vbs script's lead & + -- drop the merge-error table.+ db1 # commit+ return ()++newTable :: Table -> Database a -> IO ()+newTable (tabNm, cols) db = do+ let createStmt = createTable tabNm cols+ view <- db # openView createStmt+ view # execute ()+ return ()+ where+ createTable nm ls =+ unwords [ "CREATE TABLE"+ , backTick nm+ , inParen (concat (intersperse "," columns) ++ primKeys)+ ]+ where+ columns = map mkCol ls+ + primKeys+ | null prims = ""+ | otherwise = " PRIMARY KEY " ++ concat (intersperse "," (map (\ (x,_) -> x) prims))+ + prims = filter isPrimKey ls+ + isPrimKey (_,(_,f,_)) = f+ + mkCol (colNm, (nonNull, _isKey, cType))+ = unwords [ backTick colNm+ , tyStr+ , nullStr+ , locStr+ ]+ where+ nullStr = if nonNull then "NOT NULL" else ""+ locStr = if isLoc then "LOCALIZABLE" else ""++ (tyStr,isLoc) = + case cType of+ INT -> ("SHORT", False)+ LONG -> ("LONG", False)+ LONGCHAR l -> ("LONGCHAR", l)+ CHAR mbSz l -> (unwords ["CHAR", fromMaybe "" (fmap (inParen.show) mbSz)], l)+ OBJECT -> ("OBJECT", False)++replaceRows :: [ReplaceRow] -> Database a -> IO ()+replaceRows repls db = do+ mapM_ replRow repls+ where+ replRow (tabName, keys, vals) = db # replaceColumns tabName keys vals++replaceColumns :: String+ -> [RowKey]+ -> [Value]+ -> Database a+ -> IO ()+replaceColumns tabName keyVals newVals db = + catch + (do+ (rec, view) <- db # fetchRow tabName keyVals newVals+ zipWithM_ (setField rec) [1..] newVals+ view # modify MsiViewModifyUpdate rec+ view # close+ return ())+ (\ err -> do+ hPutStrLn stderr (unwords [ "\nTable" + , show tabName+ , ": unable to find any rows matching the following key/value pairs"+ , show keyVals+ ])+ hPutStrLn stderr (show err)+ -- just ignore+ return ())+ where+ setField rec idx (_,Nothing) = return ()+ setField rec idx (_,Just val) = + case val of + String s -> rec # setStringData idx s+ File f -> do+ h <- openFile f ReadMode -- (BinaryMode ReadMode)+ str <- hGetContents h+ rec # setStringData idx str+ hClose h+ Int i -> rec # setIntegerData idx (fromIntegral i)+ Long i -> rec # setIntegerData idx (fromIntegral i)++fetchRow :: String+ -> [(ColumnName,String)]+ -> [Value]+ -> Database a+ -> IO (Record (), View ())+fetchRow tabName keyVals vals db = do+-- hPutStrLn stderr (selectStmt tabName vals keyVals)+ view <- db # openView (selectStmt tabName vals keyVals)+ view # execute ()+ rec <- view # fetch+ when (isNullInterface rec)+ (ioError (userError "no records selected"))+ c <- rec # getFieldCount+ when (c == 0)+ (ioError (userError "no records selected"))+ return (rec, view)++selectStmt tabName vals ls = + unwords ([ "SELECT"+ , unwords fields+ , "FROM"+ , backTick tabName+ , "WHERE"+ ] ++ stuff)+ where+ fields = intersperse ", " (map (backTick.fst) vals)+ stuff = intersperse "AND" (map eq ls)+ + eq (colNm, key) = unwords [backTick colNm, "=", fwdTick key]++makeCab :: FilePath+ -> FilePath+ -> Database b+ -> Installer a+ -> IO ()+makeCab msiFile srcLoc db ip = do+ let bName = "cabber"+ let cabFile = "cabber.cab"+ let cabName = '#':cabFile+ let cabSize = "CDROM"+-- let compressType = "MSZIP"+ let compressType = "LZX"+ session <- ip # openPackage db+ shortNames <- session # getMode MsiRunModeSourceShortNames+ when (not (null srcLoc))+ (session # setProperty1 "OriginalDatabase" (srcLoc ++ "\\"))+ -- ToDo: allow different source folder to be set?+ stat <- session # doAction "CostInitialize"+ when (fromEnum stat /= fromEnum MsiDoActionStatusSuccess)+ (hPutStrLn stderr "makeCab: CostInitialize failed")+ -- sequence the File table+ view <- db # openView "SELECT Sequence,Attributes FROM File"+ catch (view # execute ())+ (\ e -> putStrLn "File selection failed" >> ioError e)+ let+ findSeq lSeq = do+ rec <- view # fetch+ if (isNullInterface rec) then+ return lSeq+ else do+ seq <- rec # getIntegerData 1+ att <- rec # getIntegerData 2+ findSeq (if ((att .&. 0x00004000) == 0) && (seq > lSeq) then seq else lSeq)+ lSeq <- findSeq 0+ view <- db # openView "SELECT File,FileName,Directory_,Sequence,File.Attributes FROM File,Component WHERE Component_=Component ORDER BY Directory_"+ catch (view # execute ())+ (\ e -> putStrLn "Directory selection failed" >> ioError e)+ let ddfFile = bName ++ ".ddf"+ hFile <- openFile ddfFile WriteMode+ let ct = (0::Int)+ hPutStrLn hFile+ (unlines [ unwords ["; Generated from" , msiFile, "on", show ct]+ , ".Set CabinetNameTemplate=" ++ bName ++ "*.CAB"+ , ".Set CabinetName1=" ++ cabFile+ , ".Set ReservePerCabineSize=8"+ , ".Set MaxDiskSize=" ++ cabSize+ , ".Set CompressionType=" ++ compressType+ , ".Set CompressionLevel=7"+ , ".Set CompressionMemory=21"+ , ".Set InfFileLineFormat=(*disk#*) *file#*: *file* = *Size*"+ , ".Set InfFileName=" ++ bName ++ ".INF"+ , ".Set RptFileName=" ++ bName ++ ".RPT"+ , ".Set InfHeader="+ , ".Set InfFooter="+ , ".Set DiskDirectoryTemplate=."+ , ".Set Compress=ON"+ , ".Set Cabinet=ON"+ ])+ let+ relabelFiles :: Int32 -> Bool -> [String] -> IO (Int32, Bool, [String])+ relabelFiles lSeq addedFiles msgs = do+ rec <- view # fetch+ if (isNullInterface rec) then+ return (lSeq, addedFiles, msgs)+ else do+ fKey <- rec # getStringData 1+ fName <- rec # getStringData 2+ folder <- rec # getStringData 3+ sequ <- rec # getIntegerData 4+ attrs <- rec # getIntegerData 5+ if (attrs .&. 0x00002000) == 0 + then do -- uncompressed.+ lSeq' <- do+ if sequ <= lSeq then do+ rec # setIntegerData 4 (lSeq + 1)+ view # modify MsiViewModifyUpdate rec+ return (lSeq + 1)+ else+ return lSeq+ let (short,long') = break (=='|') fName+ let fName'+ | null short = fName+ | shortNames = short+ | not (null long') = tail long'+ | otherwise = fName++ sPath <- catch (session # getSourcePath folder)+ (\ e -> hPutStrLn stderr ("error: " ++ show (fKey,fName,folder)) >> ioError e)+ let sourcePath = sPath ++ fName'+ hPutStrLn hFile ("\"" ++ sourcePath ++ "\" " ++ fKey)+ st <- ip # fileAttributes sourcePath+ relabelFiles lSeq' True (if st == -1 then (sourcePath : msgs) else msgs)+ else do+ relabelFiles lSeq True msgs+ (lSeq, addedFiles, msgs) <- relabelFiles lSeq False []+ hClose hFile+ when (not (null msgs))+ (hPutStrLn stderr ("The following files were not available:" ++ show (unlines msgs)))+ if not addedFiles+ then do+ hPutStrLn stderr "WARNING: no files in file table; is your installer really supposed to be file-less?"+ return ()+ else do+ rc <- system $+ unwords [ "makecab.exe /V0 /f"+ , ddfFile+ ] + when (rc /= ExitSuccess)+ (hPutStrLn stderr "makecab failed")+ view <- db # openView "SELECT DiskId, LastSequence, Cabinet FROM Media ORDER BY DiskId"+ view # execute ()+ rec <- view # fetch + (rec,uMode) <-+ if (isNullInterface rec) then do+ rec <- ip # createRecord 3+ rec # setIntegerData 1 1+ return (rec, MsiViewModifyInsert)+ else+ return (rec, MsiViewModifyUpdate)+ rec # setIntegerData 2 lSeq+ rec # setStringData 3 cabName+ view # modify uMode rec+ sumInfo <- db # getSummaryInformation (3::Int32)+ n <- now+ sumInfo # setProperty0 11 n+ sumInfo # setProperty0 13 n + sumInfo # setProperty0 15 (if shortNames then (3::Int32) else 2)+ sumInfo # persist+ + view <- db # openView "SELECT `Name`,`Data` FROM _Streams"+ view # execute ()+ rec <- ip # createRecord 2+ rec # setStringData 1 cabFile+ rec # setStream 2 cabFile+ view # modify MsiViewModifyAssign rec+ return ()+ -- remove residuals.+ removeFile "cabber.INF" `catch` (\ _ -> return ())+ removeFile "cabber.ddf" `catch` (\ _ -> return ())+ removeFile "cabber.RPT" `catch` (\ _ -> return ())+ removeFile "cabber.cab" `catch` (\ _ -> return ())+ return ()++now :: IO Date+now = do+ x <- getClockTime+ d <- clockTimeToDate x+ return d+
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2007, Galois, Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following three +conditions are met: + +Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +Neither the name of Galois nor the names of its contributors may be used +to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,64 @@+-- +-- (c) 2007, Galois, Inc. +-- +-- Main module for an installer creator. +-- +module Main ( main ) where + +import Bamse.Package +import Bamse.Builder + +{- BEGIN_CPP +import PACKAGE as PackageSrc + ELSE_NO_CPP -} +{- + This tool currently gets the package specification from + a Haskell module -- see templates/Base.hs for the signature + the module is expected to provide. +-} +--import Greencard as PackageSrc +--import HDirectLib as PackageSrc +--import ComPkg as PackageSrc +--import GaloisPkg as PackageSrc +import Cryptol as PackageSrc +--import Bamse as PackageSrc +--import GHC as PackageSrc +--import Happy as PackageSrc +--import HCDSA as PackageSrc +--import Hugs98 as PackageSrc +--import Hugs98Net as PackageSrc +--import Base as PackageSrc +{- END_CPP -} + +main :: IO () +main = genBuilder pkg_data + +-- first class modules, old skool. +pkg_data :: PackageData +pkg_data = defPackageData + { p_fileMap = PackageSrc.dirTree + , p_distFileMap = PackageSrc.distFileMap + , p_defOutFile = PackageSrc.defaultOutFile + , p_pkgInfo = PackageSrc.pkg + , p_webSite = PackageSrc.webSite + , p_bannerBitmap = PackageSrc.bannerBitmap + , p_bgroundBitmap = PackageSrc.bgroundBitmap + , p_registry = PackageSrc.registry + , p_baseFeature = PackageSrc.baseFeature + , p_features = PackageSrc.features + , p_featureMap = PackageSrc.featureMap + , p_startMenu = PackageSrc.startMenu + , p_desktopShortcuts = PackageSrc.desktopShortcuts + , p_extensions = PackageSrc.extensions + , p_verbs = PackageSrc.verbs + , p_license = PackageSrc.license + , p_userRegistration = PackageSrc.userRegistration + , p_defaultInstallFolder = PackageSrc.defaultInstallFolder + , p_userInstall = PackageSrc.userInstall + , p_finalMessage = PackageSrc.finalMessage + , p_notForAll = PackageSrc.userInstall + , p_services = PackageSrc.services + , p_ghcPackage = PackageSrc.ghcPackageInfo + , p_nestedInstalls = PackageSrc.nestedInstalls + } +
+ README view
@@ -0,0 +1,3 @@+This is the toplevel directory of 'bamse', a tool for +creating builders for Microsoft Windows Installer packages. +See doc/ for instructions on how to get started.
+ Setup.hs view
@@ -0,0 +1,8 @@+module Main(main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain + +
+ System/Path.hs view
@@ -0,0 +1,45 @@+{- |+ + Module : System.Path+ Copyright : (c) Galois Connections 2001-2004++ Maintainer : lib@galois.com+ Stability : + Portability : + + Platform specific path definitions.+-}+module System.Path+ ( pathSep -- :: Char+ , canonPath -- :: String -> String+ , isPathSeparator -- :: Char -> Bool+ , drivePath -- :: FilePath -> Maybe Char+ , isSeparator -- :: Char -> Bool+ ) where++-- | preferred path separator for the platform.+pathSep :: Char+pathSep = '\\'++-- | given a filepath, POSIX or otherwise, convert it into a+-- platform-friendly form.+canonPath :: FilePath -> FilePath+canonPath xs = map toBwd xs+ where toBwd '/' = '\\'+ toBwd x = x++-- | returns 'True' if character is a separator\/divider in a filepath.+isSeparator :: Char -> Bool+isSeparator = isPathSeparator++-- deprecated (but I'll resist the temptation of+-- adding an annoying deprecated pragma.)+isPathSeparator :: Char -> Bool+isPathSeparator '/' = True+isPathSeparator '\\' = True+isPathSeparator _ = False++-- | return drive portion part of path, if any (and meaningful.)+drivePath :: FilePath -> Maybe Char+drivePath (x:':':s:_) | isPathSeparator s = Just x+drivePath _ = Nothing
+ Util/Dir.hs view
@@ -0,0 +1,120 @@+{- |+ + Module : Util.Dir+ Copyright : (c) Galois Connections 2002++ Maintainer : lib@galois.com+ Stability : + Portability : + + File system directory utilities.+-}+module Util.Dir+ ( -- *Types+ GenDirTree(..)+ , DirTree+ -- * Functions+ , allFiles -- :: FilePath -> IO DirTree+ , findFiles -- :: (FilePath -> Bool) -> FilePath -> IO DirTree+ , findFilesRel -- :: (FilePath -> Bool) -> FilePath -> IO DirTree+ , showDirTree -- :: Maybe Int -> DirTree -> String+ ) where++import Data.Maybe ( fromMaybe )+import Control.Monad ( when )+import System.Directory+import Data.List+import System.Path+import Util.Path ( baseName )++-- | A tree \/ forest of files.+type DirTree = GenDirTree FilePath++data GenDirTree a+ = File a+ | Directory a [GenDirTree a]+ | Empty+ deriving ( Eq, Show )++instance Functor GenDirTree where+ fmap f (File name) = File (f name)+ fmap f (Directory name ts) = Directory (f name) (map (fmap f) ts)+ fmap _ (Empty) = Empty++-- | @showDirTree mbIndent tree@ shows the directory+-- tree, with each file\/directory appearing on a line+-- of their own. @mbIndent@ controls how much to indent+-- directory entries by. If @Nothing@, entries are indented+-- by two spaces.+showDirTree :: Maybe Int -> DirTree -> String+showDirTree mbIndent d = unlines $ showDir 0 d+ where+ indent_delta = fromMaybe 2 mbIndent++ showDir n Empty = [indent n ""]+ showDir n (File fpath) = [indent n fpath]+ showDir n (Directory nm sub) =+ indent n nm :+ concatMap (showDir (n+indent_delta)) sub++ indent n x = replicate n ' ' ++ x++-- | given a filepath, build up a @DirTree@ containing+-- all files and directories reachable (below that path.)+allFiles :: FilePath -> IO DirTree+allFiles fpath = findFiles (const True) fpath++-- | @findFiles pred path@ builds up a @DirTree@ +-- containing all files\/directories that satisfy+-- the predicate @pred@. The file and directory names+-- in the result appear in full, e.g., if @a.hs@ is+-- a file in the directory @path@, it appears in the+-- result as @(File \"path\/a.hs\"@+findFiles :: (FilePath -> Bool)+ -> FilePath+ -> IO DirTree+findFiles predcsr fpath = findFiles' True predcsr fpath++findFiles' :: Bool -> (FilePath -> Bool) -> FilePath -> IO DirTree+findFiles' isTopLevel predcsr fpath+ | not (predcsr fpath) = return Empty+ | otherwise = do+ let findFiles'' = findFiles' False+ isFileThere <- doesFileExist fpath+ isDirThere <- doesDirectoryExist fpath+ case (isFileThere, isDirThere) of+ (True, _) -> return (File fpath)+ (_, True) -> do+ stuff <- getDirectoryContents fpath+ let stuff' = filter (not.isUpDown) stuff+ more_stuff <- mapM (findFiles'' predcsr) (map (\ x -> fpath++[pathSep]++ x) stuff')+ let more_stuff' = filter (not.isEmpty) more_stuff+ return (Directory fpath more_stuff')+ (False, False) -> do+ when (isTopLevel)+ (fail $ unwords [ "DirUtils.findFiles: file/directory"+ , fpath+ , "not found."+ ])+ return Empty -- don\'t throw exceptions for broken symlinks+++-- | @findFilesRel pred path@ behaves like @findFiles@, except+-- files and directory names in the result are in /basename/ form,+-- e.g., if @a.hs@ is a file in the directory @path@, it appears+-- in the result as @(File \"a.hs\"@.+findFilesRel :: (FilePath -> Bool)+ -> FilePath+ -> IO DirTree+findFilesRel predcsr fpath = do+ tree <- findFiles predcsr fpath+ return (fmap baseName tree)++isEmpty :: GenDirTree a -> Bool+isEmpty Empty = True+isEmpty _ = False++isUpDown :: String -> Bool+isUpDown "." = True+isUpDown ".." = True+isUpDown _ = False
+ Util/GetOpts.hs view
@@ -0,0 +1,206 @@+{- |++ Module : Util.GetOpts+ Copyright : (c) Galois Connections, 2004++ Maintainer : lib@galois.com+ Stability : + Portability : ++ Accumulator-style command-line option parsing; minor extension+ of @System.Console.GetOpt@ (whose interface this module re-exports).+-}++-----------------------------------------------------------------------------+-- No claim to originality here, so include header from original module:+-- +-- Module : System.Console.GetOpt+-- Copyright : (c) Sven Panne Oct. 1996 (small changes Dec. 1997)+-- License : BSD-style (see the file libraries/core/LICENSE)+-- +-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : portable+--+-- A Haskell port of GNU's getopt library +--+-----------------------------------------------------------------------------++module Util.GetOpts+ ( module System.Console.GetOpt,+ getOpt2 -- :: ArgOrder (a->a) + -- -> [OptDescr (a->a)]+ -- -> [String]+ -- -> a+ -- -> (a,[String],[String])+ , usageInfo2 -- :: String -> [OptDescr a] -> String+ )+where++import Prelude+import Data.List ( isPrefixOf )+import Text.PrettyPrint+import System.Console.GetOpt++{- |+ The @getOpt@ provided @System.Console.GetOpt@ returns a list of+ values representing the options found present in an @argv@-vector.++ @getOpt2@ offers a different view -- the options are represented+ by a single value instead, i.e., you define a labelled field record+ type representing the options supported, and have the OptDescr+ elements just update the contents of that record. This has proven+ to be quite a bit less cumbersome to work with, leaving you at+ the end with a single value (the record) packaging up all the+ options setting.+ + With @getOpt@, you normally end up (essentially) having to+ write a sub parser of the list of values returned, which just+ adds even more bulk to your code, for very little benefit.+-}+getOpt2 :: ArgOrder (a -> a) -- non-option handling+ -> [OptDescr (a -> a)] -- option descriptors+ -> [String] -- the commandline arguments+ -> a -- initial state+ -> (a,[String],[String]) -- (options,non-options,error messages)+getOpt2 _ _ [] st = (st,[],[])+getOpt2 ordering optDescr (arg:args) st = procNextOpt opt ordering+ where procNextOpt (Opt f) _ = (f st',xs,es)+ procNextOpt (NonOpt x) RequireOrder = (st,x:rest,[])+ procNextOpt (NonOpt x) Permute = (st',x:xs,es)+ procNextOpt (NonOpt x) (ReturnInOrder f) = (f x st', xs,es)+ procNextOpt EndOfOpts RequireOrder = (st',rest,[])+ procNextOpt EndOfOpts Permute = (st',rest,[])+ procNextOpt EndOfOpts (ReturnInOrder f) = (foldr f st' rest,[],[])+ procNextOpt (OptErr e) _ = (st',xs,e:es)++ (opt,rest) = getNext arg args optDescr+ (st',xs,es) = getOpt2 ordering optDescr rest st++-- getOpt2 supporting code - copied verbatim from System.Console.GetOpt +-- as it isn't exported.++data OptKind a -- kind of cmd line arg (internal use only):+ = Opt a -- an option+ | NonOpt String -- a non-option+ | EndOfOpts -- end-of-options marker (i.e. "--")+ | OptErr String -- something went wrong...++-- take a look at the next cmd line arg and decide what to do with it+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr+getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr+getNext a rest _ = (NonOpt a,rest)++-- handle long option+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+longOpt ls rs optDescr = long ads arg rs+ where (opt,arg) = break (=='=') ls+ options = [ o | o@(Option _ xs _ _) <- optDescr,+ l <- xs,+ opt `isPrefixOf` l+ ]+ ads = [ ad | Option _ _ ad _ <- options ]+ optStr = ("--"++opt)++ long (_:_:_) _ rest = (errAmbig options optStr,rest)+ long [NoArg a ] [] rest = (Opt a,rest)+ long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest)+ long [ReqArg _ d] [] [] = (errReq d optStr,[])+ long [ReqArg f _] [] (r:rest) = (Opt (f r),rest)+ long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest)+ long [OptArg f _] [] rest = (Opt (f Nothing),rest)+ long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest)+ long _ _ rest = (errUnrec optStr,rest)++-- handle short option+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])+shortOpt x ys rest1 optDescr = short ads ys rest1+ where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ]+ ads = [ ad | Option _ _ ad _ <- options ]+ optStr = '-':[x]++ short (_:_:_) _ rest = (errAmbig options optStr,rest)+ short (NoArg a :_) [] rest = (Opt a,rest)+ short (NoArg a :_) xs rest = (Opt a,('-':xs):rest)+ short (ReqArg _ d:_) [] [] = (errReq d optStr,[])+ short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)+ short (ReqArg f _:_) xs rest = (Opt (f xs),rest)+ short (OptArg f _:_) [] rest = (Opt (f Nothing),rest)+ short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest)+ short [] [] rest = (errUnrec optStr,rest)+ short [] xs rest = (errUnrec optStr,('-':xs):rest)++-- miscellaneous error formatting++errAmbig :: [OptDescr a] -> String -> OptKind a+errAmbig ods optStr =+ OptErr $ usageInfo header ods+ where header = "option '" ++ optStr ++ "' is ambiguous; could be one of:"++errReq :: String -> String -> OptKind a+errReq d optStr =+ OptErr $ "option '" ++ optStr ++ "' requires an argument " ++ d++errUnrec :: String -> OptKind a+errUnrec optStr =+ OptErr $ "unrecognized option '" ++ optStr ++ "'"++errNoArg :: String -> OptKind a+errNoArg optStr =+ OptErr $ "option '" ++ optStr ++ "' doesn't allow an argument"++usageInfo2 :: String -- header+ -> [OptDescr a] -- option descriptors+ -> String -- nicely formatted decription of options+usageInfo2 header optDescr = render $ vcat $ text header : table+ where+ (ss, ls, descs) = unzip3 $ map fmtOpt optDescr+ table = + let (c1, ssd) = sameLen ss+ (c2, lsd) = sameLen ls+ in+ zipWith3 (paste (74 - c1 - c2)) ssd lsd descs+ paste c3 x y z = nest 2 $ x <+> space <> y <> space <+> fitText c3 z+ sameLen xs =+ let width = maximum $ map length xs+ in+ (width, flushLeft width xs)+ flushLeft n xs = [ text $ take n (x ++ repeat ' ') | x <- xs ]++ fmtOpt :: OptDescr a -> (String, String, String)+ fmtOpt (Option sos los argdesc descr) =+ ( render $ hcat $ punctuate comma $ map (fmtShort argdesc) sos + , render $ hcat $ punctuate comma $ map (fmtLong argdesc) los+ , descr+ )+ where+ fmtShort :: ArgDescr a -> Char -> Doc+ fmtShort (NoArg _ ) so = char '-' <> char so+ fmtShort (ReqArg _ ad) so = char '-' <> char so <+> text ad+ fmtShort (OptArg _ ad) so = char '-' <> char so <+> brackets (text ad)++ fmtLong :: ArgDescr a -> String -> Doc+ fmtLong (NoArg _ ) lo = text "--" <> text lo+ fmtLong (ReqArg _ ad) lo = text "--" <> text lo <> equals <> text ad+ fmtLong (OptArg _ ad) lo = text "--" <> text lo <> equals <>+ brackets (text ad)++-- | Simple line formatting of a paragraph, introducing line breaks+-- whenever length exceeds that of the first argument.+fitText :: Int -> String -> Doc+fitText width s = + vcat $ map (hsep . (map text))+ (fit 0 [] (words s))+ where+ -- fill up lines left-to-right, introducing line breaks + -- whenever line length exceeds 'width'.+ fit :: Int -> [String] -> [String] -> [[String]]+ fit _ acc [] = [reverse acc]+ fit n acc (w:ws)+ | (n + l) >= width = (reverse (w:acc)) : fit 0 [] ws+ | otherwise = fit (n+l+1{-word space-}) (w:acc) ws+ where+ l = length w+
+ Util/List.hs view
@@ -0,0 +1,97 @@+{-# OPTIONS -fglasgow-exts #-}+{- |++ Module : Util.List+ Copyright : (c) Galois Connections 2001, 2002++ Maintainer : lib@galois.com+ Stability :+ Portability :++ List routines needed by Bamse.+-}+module Util.List+ ( split -- :: (Eq a) => a -> [a] -> [[a]]+ , splitBy -- :: (a -> Bool) -> [a] -> [[a]]+ , lookupBy -- :: (a -> Bool) -> [a] -> Maybe a+ , revDropWhile -- :: (a -> Bool) -> [a] -> [a]+ , mapFirstDefault -- :: a -> (a -> Maybe a) -> [a] -> [a]+ , enclose -- :: [a{-pre-}] -> [a{-suff-}] -> [a{-list-}] -> [a]++ , mapFst -- :: (a -> b) -> [(a,c)] -> [(b,c)]+ , mapSnd -- :: (a -> b) -> [(c,a)] -> [(c,b)]+ , init0+ , ifCons -- :: Bool -> a -> [a] -> [a]+ + , concatWith -- :: a -> [[a]] -> [a]+ ) where++import Data.List++split :: (Eq a) => a -> [a] -> [[a]]+split elt ls = splitBy (==elt) ls++splitBy :: (a -> Bool) -> [a] -> [[a]]+splitBy _ [] = []+splitBy p ls =+ case break p ls of+ (bef,[]) -> [bef]+ (bef,_:xs) -> bef : splitBy p xs++--+-- consistent naming, provide 'find' as 'lookupBy'.+--+lookupBy :: (a -> Bool) -> [a] -> Maybe a+lookupBy = find++--+-- revDropWhile p = reverse . dropWhile p . reverse+--+revDropWhile :: (a -> Bool) -> [a] -> [a]+revDropWhile p = foldr f []+ where f x [] | p x = []+ | otherwise = [x]+ f x xs@(_:_) = x:xs++mapFirstDefault :: a+ -> (a -> Maybe a)+ -> [a]+ -> [a]+mapFirstDefault def _ [] = [def]+mapFirstDefault def f (x:xs) =+ case f x of+ Nothing -> x : mapFirstDefault def f xs+ Just x' -> x' : xs++--+-- mapping over just one component of a pair is not that+-- uncommon. As we all know, trivial to write out in terms+-- of 'map', but you shouldn't have to!+--+mapFst :: (a -> b) -> [(a,c)] -> [(b,c)]+mapFst f = map (\ (x,y) -> (f x,y))++mapSnd :: (a -> b) -> [(c,a)] -> [(c,b)]+mapSnd f = map (\ (x,y) -> (x,f y))++--+-- add a prefix and a suffix to a list.+--+enclose :: [a{-pre-}] -> [a{-suff-}] -> [a{-list-}] -> [a]+enclose p s ls = p ++ (ls ++ s)++init0 :: [a] -> [a]+init0 [] = []+init0 ls = init ls++-- | conditional cons+ifCons :: Bool -> a -> [a] -> [a]+ifCons True x xs = x:xs+ifCons _ _ xs = xs++-- intersperses with the separator before concat'ing+concatWith :: a -> [[a]] -> [a]+concatWith _ [] = []+concatWith sep xss =+ foldr1 ( \ xs yss -> xs ++ (sep : yss) ) xss+
+ Util/Path.hs view
@@ -0,0 +1,256 @@+{- |+ + Module : Util.Path+ Copyright : (c) Galois Connections 2001, 2002++ Maintainer : lib@galois.com+ Stability : + Portability : + + Working with file system paths.+-}+module Util.Path+ ( module System.Path+ , buildPath -- :: String -> [FilePath] -> FilePath+ , toAbsolutePath -- :: FilePath -> FilePath -> FilePath+ , toRelativePath -- :: FilePath -> FilePath -> FilePath+ , dirName -- :: FilePath -> FilePath+ , baseName -- :: FilePath -> FilePath+ , dropSuffix -- :: FilePath -> FilePath+ , changeSuffix -- :: String -> FilePath -> FilePath+ , fileSuffix -- :: FilePath -> String+ , splitPath -- :: FilePath -> [String]+ , splitPath2 -- :: FilePath -> [FilePath]+ , initsPath -- :: FilePath -> [FilePath]+ , joinPath -- :: [String] -> FilePath+ , dirname -- :: FilePath -> FilePath+ , appendSep -- :: FilePath -> FilePath+ , appendSepPosix -- :: FilePath -> FilePath+ , dropSepTrail -- :: FilePath -> FilePath+ , appendPath -- :: FilePath -> FilePath -> FilePath+ , appendPathPosix -- :: FilePath -> FilePath -> FilePath+ , prefixDir -- :: String -> String -> String++ , toPosixPath -- :: FilePath -> FilePath+ , toPlatformPath -- :: FilePath -> FilePath+ ) where++import Data.List++import Util.List ( revDropWhile, init0 )+import System.Path++-- | @buildPath sep paths@ joins together @paths@, interspersed+-- by @sep@.+buildPath :: String -> [FilePath] -> String+buildPath sep = concat . intersperse sep++-- | @splitPath p@ breaks up the file path @p@ into parts+-- separated by 'System.Path.isSeparator'+-- +-- @+-- splitPath \"c:\/foo\/bar\/baz\/my.c\" = [\"c:\", \"foo\", \"bar\", \"baz\", \"my.c\"]+-- splitPath \"\/foo\/\/\/bar\/\/\" = [\"\", \"foo\", \"bar\"]+-- @+splitPath :: FilePath -> [String]+splitPath "" = []+splitPath s = d : splitPath (dropWhile isSeparator s')+ where (d,s') = break isSeparator s++-- | @splitPath2 path@ returns the sub-paths that make+-- up @path@.+-- +-- @+-- splitPath \"\/etc\/rc.d\/foo\" = [\"\/\",\"\/etc\", \"\/etc\/rc.d\", \"\/etc\/rc.d\/foo\"]+-- @+splitPath2 :: FilePath -> [FilePath]+splitPath2 = map joinPath . tail . inits . splitPath+ -- ToDo: give it a better name.++-- | @joinPath parts@ constructs a new file path out+-- of @parts@, interspersing them by 'System.Path.pathSep'.+-- It differs from 'buildPath' in that an empty list of+-- @parts@ maps to @.@, and if @parts@ is equal to @[\"\"]@,+-- the root directory is returned.+-- +joinPath :: [String] -> FilePath+joinPath [] = "."+joinPath [""] = [pathSep]+joinPath ds = concat (intersperse [pathSep] ds)+-- The two special cases above look a bit 'odd-hoc' :)+++-- | @toAbsolutePath curr rel@ returns a new file path+-- by navigating from @curr@ using the relative path+-- @rel@ . @curr@ is assumed to be an absolute path,+-- and @rel@ a relative one.+toAbsolutePath :: FilePath -> FilePath -> FilePath+toAbsolutePath current relative = absolute where+ absolute = joinPath (reverse absDirs)+ curDirs = reverse (splitPath current)+ relDirs = splitPath relative+ absDirs = foldl chdir curDirs relDirs+ chdir ds ".." = case ds of+ [""] -> ds -- toAbsolutePath "/foo" "../../bar" = "/bar"+ [] -> [".."] -- toAbsolutePath "foo" "../../bar" = "../bar"+ ("..":_) -> "..":ds+ (_:ds') -> ds'+ chdir ds "." = ds+ chdir _ "" = [""]+ chdir ds d = d:ds++-- | @toRelativePath path1 path2@ computes the relative path+-- required to navigate from @path1@ to @path2@.+toRelativePath :: FilePath -> FilePath -> FilePath+toRelativePath current absolute = if null relative then "." else relative where+ relative = joinPath relDirs+ curDirs = splitPath current+ absDirs = splitPath absolute+ (curDirs', absDirs') = dropCommonPrefix curDirs absDirs+ relDirs = (map (const "..") curDirs') ++ absDirs'+ dropCommonPrefix (a:as) (b:bs) | a == b = dropCommonPrefix as bs+ dropCommonPrefix as bs = (as,bs)++-- | @baseName path@ is the dual to @dirName@, returning the filename+-- portion after the last occurrence of a path separator in @path@.+-- If @path@ doesn't contain a path separator, @path@ is returned.+baseName :: FilePath -> FilePath+baseName p = findLast isSeparator p p'+ where+ p' = dropSepTrail p++-- | @dirName path@ returns the directory portion of file path @path@,+-- i.e., everything upto (and including) the last directory separator.+-- If @path@ doesn't contain a path separator, @.\/@ is returned.+dirName :: FilePath -> FilePath+dirName fname =+ case revDropWhile (not.isSeparator) (revDropWhile isSeparator fname) of+ "" -> "./" -- no separator was found, dir-name is "."+ xs -> xs++-- | @dirname path@ is identical to 'dirName', except+-- if @path@ doesn't contain a path separator, @.@ is+-- returned ('dirName' return @.\/@ instead.) @dirname@+-- mirrors the Unix "dirname" command.+dirname :: FilePath -> FilePath+dirname = joinPath . init0 . splitPath++-- | @dropSepTrail path@ returns @path@ with trailing separators+-- stripped from it.+dropSepTrail :: FilePath -> FilePath+dropSepTrail p = go p+ where+ go [] = []+ go (x:xs) + | isSeparator x = case go xs of { [] -> []; ys -> x:ys }+ | otherwise = x : go xs++-- | Return the file suffix\/file extension. The suffix /does not/+-- include the dot. In case there isn't a suffix, return empty string.+fileSuffix :: FilePath -> String+fileSuffix = findLast (=='.') ""++findLast :: (Char -> Bool)+ -> String+ -> String+ -> String+findLast p noMatch f = go False f f+ where+ go matched acc []+ | matched = acc+ | otherwise = noMatch+ go matched acc (x:xs)+ | p x = go True xs xs+ | otherwise = go matched acc xs++-- | @dropSuffix path@ chops off the file extension of @path@+-- (including the dot.) If @path@ doesn't have a file extension,+-- @path@ is returned.+dropSuffix :: FilePath -> FilePath+dropSuffix f = replaceSuffixWith "" f++-- | @changeSuffix ext path@ changes @path@\'s file extension+-- to @ext@. If @path@ doesn't have a file extension, @ext@+-- is appended.+changeSuffix :: String -> FilePath -> FilePath+changeSuffix ext f =+ replaceSuffixWith (case ext of { '.':_ -> ext ; _ -> '.':ext }) f++replaceSuffixWith :: String -> String -> String+replaceSuffixWith suf fname = + case (go fname) of+ (False, xs) -> xs+ (True,_) -> fname ++ suf+ where+ go :: String -> (Bool, String)+ go "" = (True, "")+ go ('.':'.':x:xs)+ | x == pathSep+ = (False, '.':'.':x:res)+ where+ (_, res) = go xs+ go (x:xs)+ | x == '.' = (False, if isLastDot then suf else x:res)+ | otherwise = (isLastDot, x:res)+ where+ (isLastDot, res) = go xs++-- | @appendSepPosix path@ adds a path separator at the end of @path@,+-- unless it already has one.+appendSepPosix :: FilePath -> FilePath+appendSepPosix p = appendSep' '/' p++-- | @appendSepPosix path@ adds a (platform-specific) path separator at the end of @path@,+-- unless it already has one.+appendSep :: FilePath -> FilePath+appendSep p = appendSep' pathSep p++-- internal helper function+appendSep' :: Char -> FilePath -> FilePath+appendSep' _ "" = ""+appendSep' s [x]+ | isSeparator x = [x]+ | otherwise = [x, s]+appendSep' s (x:xs) = x : appendSep' s xs++-- | @appendPathPosix path0 path1@ appends @path1@ onto the end of @path0@, +-- separating the two using a forward slash.+appendPathPosix :: FilePath -> FilePath -> FilePath+appendPathPosix p0 p1 = (appendSepPosix p0) ++ p1++-- | @appendPath path0 path1@ appends @path1@ onto the end of @path0@.+appendPath :: FilePath -> FilePath -> FilePath+appendPath p0 p1 = (appendSep p0) ++ p1++-- | @initsPath path@ returns the 'inits' of @path@+--+-- @+-- initsPath \"\/foo\/bar\/blah\" == [ \"\/\", \"\/foo\", \"\/foo\/bar\", \"\/foo\/bar\/blah\" ]+-- @++initsPath :: FilePath -> [FilePath]+initsPath = splitPath2++-- | @toPosixPath path@ normalises the path separators to forward+-- slashes. Easier to work with.+toPosixPath :: FilePath -> FilePath+toPosixPath = map subst+ where+ subst '\\' = '/'+ subst x = x++-- | @toPlatformPath path@ converts a path into platform-specific form.+toPlatformPath :: FilePath -> FilePath+toPlatformPath = map subst+ where+ subst x+ | isSeparator x = pathSep+ | otherwise = x++-- | +prefixDir :: FilePath -> FilePath -> FilePath+prefixDir [] rest = rest+prefixDir ['/'] rest = '/':rest+prefixDir ['\\'] rest = '/':rest+prefixDir [x] rest = x:'/':rest+prefixDir (x:xs) rest = x : prefixDir xs rest
+ art/README.txt view
@@ -0,0 +1,9 @@+The UI templates we use allows you to override two +of the bitmaps used: + + * Headline banner -- this has got to be a .bmp of + dimensions 500x63 + + * backdrop image on start and finish dialogs -- this + has got to be a .bmp of dimensions 503x315 +
+ art/banner.bmp view
binary file changed (absent → 31682 bytes)
+ art/banner2.bmp view
binary file changed (absent → 94554 bytes)
+ art/banner3.bmp view
binary file changed (absent → 94554 bytes)
+ art/bground.bmp view
binary file changed (absent → 476334 bytes)
+ art/bground2.bmp view
binary file changed (absent → 476334 bytes)
+ art/dlgbmp3rd.bmp view
binary file changed (absent → 154542 bytes)
+ art/galois-bground-fade.jpg view
binary file changed (absent → 99671 bytes)
+ art/galois-bground.JPG view
binary file changed (absent → 280160 bytes)
+ art/ghc-background-3rd.bmp view
binary file changed (absent → 52738 bytes)
+ art/ghc-background.bmp view
binary file changed (absent → 159838 bytes)
+ art/haskell-background.bmp view
binary file changed (absent → 476334 bytes)
+ art/haskell-banner.bmp view
binary file changed (absent → 32578 bytes)
+ bamse.cabal view
@@ -0,0 +1,111 @@+name: bamse +version: 0.9.1 +Synopsis: A Windows Installer (MSI) generator framework +Description: + Bamse is a framework for building Windows Installers for + your Windows applications, giving you a comprehensive set + of features to put together Windows Installers using Haskell. + +category : System +license : BSD3 +license-file : LICENSE +author : Sigbjorn Finne <sof@forkIO.com> +maintainer : sof@forkIO.com +cabal-version : >= 1.2 +build-type : Simple +extra-source-files: README + license.rtf + icons/folder.exe + icons/star.exe + icons/pdf.exe + icons/html2.exe + icons/cmdIcon.exe + icons/txt.exe + icons/html.exe + icons/hsx.exe + icons/hs.exe + doc/errors.txt + doc/howto.txt + doc/howto.html + doc/index.html + doc/using.txt + doc/using.html + doc/icons.txt + data/license.rtf + data/msi/base.msi + data/msi/UISample.msi + data/msi/Sequence.msi + data/msi/Schema.msi + art/README.txt + art/haskell-banner.bmp + art/haskell-background.bmp + art/ghc-background.bmp + art/ghc-background-3rd.bmp + art/galois-bground.JPG + art/galois-bground-fade.jpg + art/dlgbmp3rd.bmp + art/bground2.bmp + art/bground.bmp + art/banner3.bmp + art/banner2.bmp + art/banner.bmp + tools/msiIcon.h + tools/msiIcon.c + tools/README.txt + tools/Makefile + templates/Alex.hs + templates/Bamse.hs + templates/Base.hs + templates/ComPkg.hs + templates/Cryptol.hs + templates/GHC.hs + templates/GaloisPkg.hs + templates/Greencard.hs + templates/HDirectLib.hs + templates/Haddock.hs + templates/Happy.hs + templates/Hugs98.hs + templates/Hugs98Net.hs + templates/PubCryptol.hs + templates/SOE.hs + +flag old-base + description: Old, monolithic base + default: False + +library { + Exposed-modules: Bamse.Builder, + Bamse.DiaWriter, + Bamse.Dialog, + Bamse.DialogUtils, + Bamse.GhcPackage, + Bamse.IMonad, + Bamse.MSIExtra, + Bamse.MSITable, + Bamse.Options, + Bamse.Package, + Bamse.PackageGen, + Bamse.PackageUtils, + Bamse.WindowsInstaller, + Bamse.Writer + + Other-Modules: System.Path, + Util.Dir, + Util.GetOpts, + Util.List, + Util.Path + + Ghc-Options: -Wall + + build-depends: com, haskell98, directory, pretty + if flag(old-base) + Build-Depends: base < 3 + else + Build-Depends: base >= 4 +} + +executable bamse { + main-is: Main.hs + hs-source-dirs: . templates + ghc-options: -Wall +}
+ data/license.rtf view
binary file changed (absent → 161 bytes)
+ data/msi/Schema.msi view
binary file changed (absent → 45056 bytes)
+ data/msi/Sequence.msi view
binary file changed (absent → 6144 bytes)
+ data/msi/UISample.msi view
binary file changed (absent → 285696 bytes)
+ data/msi/base.msi view
binary file changed (absent → 442368 bytes)
+ doc/errors.txt view
@@ -0,0 +1,23 @@+Odd/unhelpful end-user error conditions & their possible remedy+===============================================================++* User is able to choose installation type, but after+ clicking the "Install" button to kick off the copying+ of files etc, the dialog box "Cannot find the file+ specified" (or a variant thereof) with the buttons+ Retry/Cancel. Retry doesn't help, and on hitting Cancel+ the error code 2755, 110, Unable to open "<MSI filename>"+ + The cause of this one was inappropriate permissions on the MSI+ itself. Enabling Read&Execute for everyone solves the problem.++* Error reporting for nested installs where the sub-installers+ aren't actually present (i.e., haven't been injected with 'msidb')+ isn't informative; the installer reports a fatal error after having+ completed the main installation.++* Starting up an .msi that's already opened elicits a dialog box+ informing the user that it couldn't be opened. The hints included+ in the dialog box text as to why that might be doesn't include the+ possibility that it may already be opened by another application.+
+ doc/howto.html view
@@ -0,0 +1,64 @@+<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">+<html> <head>+<title>Getting started with Bamse</title>+</head>++<body>+<h1>Getting started</h1>++Here are the steps you need to follow to author your own installer+builder:++<ul>+<li>+Install GHC and Bamse. Assuming here that you've already +done that.+<li>+Build Bamse; by default, it uses the 'Base' template,+resulting in an installer builder, mkInstaller.exe, which+simply creates empty MSI installers.++<li>+Building Bamse is done by typing 'make' in the toplevel directory,+provided you've first changed the setting of HC in the Makefile to+point to your local installation of GHC.++<li>+Create your own template module. Have a look at the +<a href="using.html">using</a> document for+information about what module signature you need to+supply. Consulting/copying examples in templates/ is also a good way+to get started.++<li>+Hook in your template by adding an import to it in Main.hs. To keep+things simple (by avoiding editing of the Makefile), just add the+template module to the templates/ directory.++<li>+re-make Bamse to produce a 'mkInstaller' builder for your project.+Use --help to discover the set of options supported, but typical+invocations are:+ +<pre>+ foo$ mkInstaller --generate-guids -o myInstaller.msi c:/path/to/the/top/of/my/dist/tree+ foo$ mkInstaller -u -o myInstaller.msi c:/path/to/the/top/of/my/dist/tree+</pre>++The latter one re-uses the GUIDs of the existing 'myInstaller.msi'+to create a new one. You want to do that to when creating updates/bugfixes+of existing products without upgrading its version numbers; please notice+that it overwrites the .msi in the end, so please make a copy if the+MSI is precious..++<li>+Ship the resulting installer and/or give us feedback on what did or+didn't work for you, plus suggestions for improvements.+</ul>++<hr>+<address>+<a href="http://www.galois.com/~sof/">sof</a>+</address>+<!-- hhmts start --> Last modified: Mon Oct 25 09:44:26 Pacific Daylight Time 2004 <!-- hhmts end -->+</body> </html>
+ doc/howto.txt view
@@ -0,0 +1,41 @@+Getting started+================++Here are the steps you need to follow to author your own installer+builder:++* Install GHC and Bamse. Assuming here that you've already + done that.++* Build Bamse; by default, it uses the 'Base' template,+ resulting in an installer builder, mkInstaller.exe, which+ simply creates empty MSI installers.++* Building Bamse is done by typing 'make' in the toplevel directory,+ provided you've first changed the setting of HC in the Makefile to+ point to your local installation of GHC.++* Create your own template module. Have a look at doc/using.txt for+ information about what module signature you need to+ supply. Consulting/copying examples in templates/ is also a good way+ to get started.++* Hook in your template by adding an import to it in Main.hs. To keep+ things simple (by avoiding editing of the Makefile), just add the+ template module to the templates/ directory.++* re-make Bamse to produce a 'mkInstaller' builder for your project.+ Use --help to discover the set of options supported, but typical+ invocations are:+ + foo$ mkInstaller --generate-guids -o myInstaller.msi c:/path/to/the/top/of/my/dist/tree+ foo$ mkInstaller -u -o myInstaller.msi c:/path/to/the/top/of/my/dist/tree++ The latter one re-uses the GUIDs of the existing 'myInstaller.msi'+ to create a new one. You want to do that to when creating updates/bugfixes+ of existing products without upgrading its version numbers; please notice+ that it overwrites the .msi in the end, so please make a copy if the+ MSI is precious..++* Ship the resulting installer and/or give us feedback on what did or+ didn't work for you.
+ doc/icons.txt view
@@ -0,0 +1,33 @@+Creating icon .exe's +====================++Each icon needs to go into an .exe of its own. Here's+how to build it:++* locate and save the icon you want to use as an .ico,+ as "MyIcon.ico" (say).++* create a one-liner resource script:++ 0 ICON "MyIcon.ico"++* build the .res file using the resource compiler:++ rc MyIcon.rc++* build the .exe -- to do this you need to supply a stub+ DllMain() and link it as follows:+ + foo$ cat stub.c+ #include <windows.h> + BOOL APIENTRY DllMain(HANDLE hDLL, DWORD dwReason, LPVOID lpReserved) + { + // Nothing to initialize. + return TRUE; + } + foo$ cl -o MyIcon.exe stub.c MyIcon.res /link /entry:DllMain /subsystem:windows+++...but sometimes you've just got an executable/DLL containing the+icon; what to do? Have a look at the tools/README and tools/msiIcon.c+
+ doc/index.html view
@@ -0,0 +1,77 @@+<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">+<html> <head>+<title>Bamse: creating batch MSI emitters</title>+</head>++<body>+<h1>Bamse: creating Windows MSI installers</h1>++Bamse is a tool that arose out of the need to be able to create+Windows installers as part of an <em>automated</em> software build+process. +<p>+The result is available for you to hopefully also make good use of+in your software projects. It offers the following features:+<ul>+<li><em>Programmatic specification of installer builders.</em><p>+By providing a Haskell module that tailors a general MSI installation+framework to the needs of your project, a command-line based+<em>installer builder</em> is produced. When invoked, it bundles+together the files and metadata that make up your installer,+outputting an MSI ready for distribution.+<p>+<li><em>Authoring shell integration</em>+<p>+On top of handling the installation of files and directories, +the tool lets you specify how to integrate its contents into the+Windows environment. For instance, the start menu items to add,+desktop shortcuts, and the creation of new file types.+<p>+<li><em>Registry handling</em>+<p>+Should your application depend on the Registry for operation,+installation of Registry keys and values can easily be added.+<p>+<li><em>Configurable UI</em>+<p>+The installation UI can easily be modified to include your own logos and+artwork.+<p>+<li><em>High-level support for building installers for GHC library packages</em>+<p>+To give Haskell developers a leg-up, special support is provided for+authoring installer builders for GHC library packages. Apart from+bundling up the files that make up your package, it also supports the+automatic registration of a package with the user's local installation+of GHC.+</ul>++<h2>Downloading and installing</h2>++Latest release: <a href="bamse.msi">bamse-0.7</a><br>. The installer+contains the sources of Bamse itself along with two GHC packages it+depends on to compile; the HDirect Com library and the Galois library.+<p>+Installation should install and register these GHC-6.2.1 packages+along with Bamse, but if they're not registered, here's how to do it+manually:++<pre>+foo$ cd "c:/Program Files/ComPkg"+foo$ hd_imp="c:/Program Files/ComPkg/imports" \+ hd_lib="c:/Program Files/ComPkg" \+ hd_inc="c:/Program Files/include" \+ c:/ghc/ghc-6.2.1/bin/ghc-pkg -u com i com.pkg+foo$ cd "c:/Program Files/GaloisPkg"+foo$ TARGETDIR="c:/Program Files/GaloisPkg" \+ c:/ghc/ghc-6.2.1/bin/ghc-pkg -u galois i galois.pkg+</pre>++To get started with Bamse, have a look at the <a href="howto.html">HOWTO</a>.++<hr>+<address>+<a href="http://www.galois.com/~sof/">sof</a>+</address>+<!-- hhmts start --> Last modified: Mon Sep 20 11:58:11 Pacific Daylight Time 2004 <!-- hhmts end -->+</body> </html>
+ doc/using.html view
@@ -0,0 +1,590 @@+<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">+<html> <head>+<title>Creating Windows Installers</title>+</head>++<body>+<h1>Creating Windows Installers</h1>++This is the user guide for a tool that tries to assist you in creating+Microsoft Windows installers. It lets you put together installer+builders for your application/library/tool, builders that can then be+used to automate the actual rolling up of shippable Windows+Installers. The tool uses Haskell to tailor the general installer+framework to the needs of your application's installation story.+<p>+Enough content-free verbiage -- let's get concrete and look at how to+author your own installer builders.++<h2>Getting started</h2>++The easiest way to get started is to look at existing installer+templates, and try to tailor these to fit; see the templates/+directory. 'bamse' uses Haskell as the specification language for+these templates, requiring the user to supply a Haskell module that+exports a collection of functions and values that define the+characteristics of an installer builder. Using an existing programming+language for this rather than invent some custom input format/schema to+specify the behaviour and contents of an installer has some+merit. It is still an open issue whether or not the power of a+programming language is required though, and something we hope to+better understand by specifying a number of installer builders.+<p>+Using the Cryptol template as our example, let's do a walkthrough of+its installation template module (we're assuming that you're vaguely+familiar with Haskell syntax):++<pre>+> module Cryptol where +>+> import Bamse.Package; import Bamse.PackageUtils+>+> import Data.List ( intersperse )+> import Util.Dir ( DirTree(..), findFiles )+> import Util.Path ( baseName )+> +</pre>++All installer builder template import the 'Bamse.Package' and 'Bamse.PackageUtils'+modules to bring into scope various types and utility functions. In+addition to these, the Cryptol template requires some list and directory/path +processing functions; the former is imported from a standard Haskell+module, the latter from the Galois Haskell library. OK, first some+helper definitions:++<pre>+> +> pkgName, pkgVersion :: String+> pkgName = "Cryptol"+> pkgVersion = "1.4"+>+</pre>++While neither 'pkgName' nor 'pkgVersion' are used outside of this+template module, abstracting them out as local definitions is handy.++<pre>+> -- what to output the MSI as if no -o option is given.+> defaultOutFile = PackageUtils.toMsiFileName (pkgName ++ '-':pkgVersion)+> +</pre>++The 'bamse' tool supports a standard set of command-line options, one+of which is the name of the file the builder should output the+installer as. In the event the user doesn't supply this option,+'defaultOutFile' is used. To make sure we don't run afoul MSI+restrictions on filenames, 'PackageUtils.toMsiFileName' is used to+translate the default filename into a valid MSI filename.++<pre>+> -- 'information summary stream' data bundled up together.+> pkg :: Package+> pkg = Package+> { name = pkgName+> , title = pkgName ++ ", version " ++ pkgVersion+> , productVersion = "1.4.2.0"+> , author = "Galois Connections, Inc."+> , comment = unwords [pkgName, "Version", pkgVersion]+> }+</pre>++The next definition collects together informational data about the+installer you're creating a builder for. The Package.Package data type+is defined as follows:++<pre>+> data Package+> = Package { +> name :: String+> -- ^ The name of the product which the installer provides.+> , title :: String+> -- ^ Brief description of installer contents.+> , productVersion :: String+> -- ^ productVersion format:+> -- major.minor.build[.whatever]+> -- +> , author :: String+> -- ^ name of manufacturer of the installer+> , comment :: String+> -- ^ short text describing purpose of installer+> }+</pre>++The meaning of these individual fields are hopefullly self-evident.+<p>+The URL associated with a product is given via the 'webSite'+definition:++<pre>+>+> webSite :: String+> webSite = "http://www.cryptol.net/"+>+</pre>++Currently, this URL is only used when specifying the 'help URL'+associated with an installer.+<p>+Customisation of an installer's UI is possible in a number of ways;+you can for instance specify the bitmaps to use as backdrop and a+banner: ++<pre>+> +> bannerBitmap :: InstallEnv -> Maybe FilePath+> bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner3.bmp")+> +> bgroundBitmap :: InstallEnv -> Maybe FilePath+> bgroundBitmap ienv = Just (lFile (toolDir ienv) "art/bground2.bmp")+> +</pre>++These are specified as functions, taking an 'InstallEnv' describing+the context the installer is invoked from. The 'toolDir' field of+an 'InstallEnv' specifies the toplevel directory of the installer+builder tool itself. It it used here to get hold of some standard+bitmaps without having to hardwire their paths into the template.+If you simply want to use the standard UI, have both of these +functions return 'Nothing'.+<p>+The 'InstallEnv' type is defined as follows:++<pre>+> data InstallEnv+> = InstallEnv +> { toolDir :: FilePath -- ^ where installer tool lives +> , srcDir :: FilePath -- ^ path to toplevel directory of files to be distributed.+> , dataDir :: FilePath -- ^ user-supplied path to directory containing installer+> -- template specific files.+> }+</pre>++The 'dataDir' field holds the path to a directory which contains files+particular to all installers for your product; for instance, instead+of using 'toolDir' above to get hold of bitmap files, 'dataDir' could+be used to get hold of Cryptol specific distribution/installer+files. The 'srcDir' directory points to the top of the directory tree+you want to package up.+<p>+Some products require the use of the Registry to store installation+specific data in order to operate properly. To specify what actions+the installer should perform upon the Registry upon installation (and+un-installation), the 'registry' list is used:++<pre>+> +> registry :: [RegEntry]+> registry = cryptolSettings ++ haskellProject "Cryptol" [....]+> +</pre>++In the case of Cryptol, it consists of two parts, one to setup the+Cryptol-specific Registry data, the other to integrate Cryptol with+your the Haskell interpreter Hugs98. For grubby Hugs versioning+issues, the setup of the latter is a little bit involved, so let's+focus on the Cryptol-specific options only (see the real template+module for complete details.)++<pre>+>+> cryptolSettings = +> [ RegEntry "HKCU" "Software" (CreateKey False)+> , RegEntry "HKCU" "Software\\Cryptol" (CreateKey True)+> , RegEntry "HKCU" "Software\\Cryptol" (CreateName (Just "Options") "")+> , RegEntry "OnInstall" "Software" (CreateKey False)+> , RegEntry "OnInstall" "Software\\Cryptol" (CreateKey True)+> , RegEntry "OnInstall" "Software\\Cryptol" (CreateName (Just "InstallDir") "[TARGETDIR]")+> ]+> +</pre>++Each 'RegEntry' consists of three fields; the first specifies the hive+(Registry lingo for the toplevel directory/key), the second the path+to the key/value to install within that hive. Notice the use of the+'OnInstall' hive here; it is a meta-hive name which is used to specify+Registry data that is supposed to go into either the machine or+user-specific portion/hive of the Registry. Which one is decided when+when the user installing the software picks a per-machine or a+per-user installation.+<p>+The third argument to RegEntry specifies what action to perform on the +given Registry key/value -- it is defined as follows:++<pre>+> +> data KeyAction+> = CreateKey Bool -- True => delete on uninstall+> | CreateName (Maybe String) -- Just x => default name for the name.+> String+> | DeleteKey Bool -- True => remove key on _install_+> -- False => remove key on _uninstall_+> | DeleteName Bool String -- True => remove name on _install_+> -- False => remove name on _uninstall_+> +</pre>++You'll be using the first two constructors most of the time to+hygenically install and un-install Registry entries for your product;+'cryptolSettings' doing just this for Cryptol, being a good citizen+by deleting its Registry tree when the application is uninstalled.+<p>+Next item on the list of things a template needs to provide is the+specification of 'features': an installer can partition the files it+distributes into a set of features, each of which the user can decide+whether or not to install locally. The root or base feature is+specified via 'baseFeature':++<pre>+> baseFeature :: Feature+> baseFeature = (baseFeatureName, pkgName ++ '-':pkgVersion)+> +> baseFeatureName :: String+> baseFeatureName = pkgName+> +> features :: [Feature]+> features = [baseFeature]+</pre>++Associated with the base feature are all essential files of your+product + installer features such as start menu entries, desktop+shortcuts, registry entries etc. The base feature is unique in that+the user cannot opt not to install it. The other features, specified+via 'features', can be de-selected at install-time by the user.+[Note: it is currently not possible to associate files/directories+with other features than 'baseFeature', making 'features' rather+useless as-is. Only thing it gives you is an selectable option on the+customised-install dialog.]+<p>+Integrating your product into the Windows graphical shell is supported+in a number of ways: start menu entries, desktop shortcuts, custom+filetypes and the definition of operations over these custom files.+Start menu items are defined via 'startMenu':++<pre>+>+> startMenu :: InstallEnv -> (String, [Shortcut])+> startMenu ienv = (pkgName, shortcuts ienv)+> +</pre>++In dictatorial fashion, 'bamse' will only let you install start menu+items in a separate folder inside the programs folder. The first+component of the 'startMenu's result pair is the folder to create (and+delete upon uninstall) -- sub-folders are created by specifying a+relative path here, e.g., "Cryptol/version1.4" (see the GHC template+for an example of this.) The second component contain the shortcuts+you want to have appear in that menu. The 'Shortcut' data type is+defined as follows:++<pre>+> +> data Shortcut+> = Shortcut+> { scut_name :: String -- name+> , scut_target :: String -- target app+> , scut_args :: String -- arguments+> , scut_desc :: String -- description+> , scut_icon :: Maybe FilePath -- icon file+> , scut_istate :: Int -- initial state+> , scut_wdir :: String -- working dir.+> }+>+</pre>++The fields are best explained via an actual example:++<pre>+> shortcuts :: InstallEnv -> [Shortcut]+> shortcuts ienv =+> [ Shortcut "Cryptol interpreter"+> (lFile topDir "bin\\cryptol.exe")+> ""+> "Cryptol interpreter"+> (Just (lFile iconDir "cry.exe"))+> 1+> "[TARGETDIR]"+> ]+> where+> topDir = srcDir ienv+> iconDir = lFile (toolDir ienv) "icons"+</pre>++The first component is the display name of the shortcut, the second+is the target file of the shortcut -- here, the binary of the Cryptol+interpreter. The third argument contain any command-line arguments to+pass the target, the fourth is the descriptive text (i.e., verbiage that+shows up when you hold the mouse cursor over the item). Next is the+icon to associate with the shortcut; -- see section Foo on details on+how to create your icon files -- here, the icon is the "standard"+Cryptol icon that comes bundled with 'bamse'. The second to last field+control how to initially show the shortcut application once launched;+1 meaning show a normal window (3 = show maximized; 7=show minimized.)+The last field is the initial working directory of the launched+application -- "[TARGETDIR]" is a meta-directory name that gets+expanded by the Microsoft Installer Runtime to the directory where the+product ended up being installed locally.+<p>+Note: if you don't want a start menu folder installed with your+product, simply leave 'startMenu's shortcut list as empty.+<p>+The Shortcut data type is naturally also used when specifying desktop+shortcuts:++<pre>+> +> desktopShortcuts :: InstallEnv -> [Shortcut]+> desktopShortcuts ienv = shortcuts ienv+> +</pre>++Making Cryptol install both a start menu and desktop shortcut to its+interpreter.+<p>+To further embed your product into the Windows shell, you have the+option of registering custom filename extensions + actions to perform+support over these:++<pre>+>+> extensions :: InstallEnv -> [ Extension ]+> extensions ienv = [ cryptolExtension (srcDir ienv (toolDir ienv) "cry" ]+> ]+</pre>++The '.cry' file extension is here associated with the Cryptol interpreter,++<pre>+> cryptolExtension :: FilePath -> FilePath -> String -> Extension+> cryptolExtension topDir toolDir ext +> = ( "CryptolFile" -- (unique) extension label+> , lFile topDir "bin\\cryptol.exe"+> , lFile iconDir "cry.exe"+> , ext+> )+> where+> iconDir = lFile toolDir "icons"+> +</pre>++together with the icon contained in the 'cry.exe' resource+binary. Operations on this file type is specified via the 'verbs'+definition:++<pre>+> verbs :: [ ( String -- extension+> , String -- verb+> , String -- label+> , String -- arguments+> )+> ]+> verbs = [ ( "cry"+> , "open"+> , "&Open"+> , "\"%1\"")]+> +</pre>++The standard 'open' action is here defined to pass the file path of+the opened/double-clicked .cry file as command-line argument to the +application associated with it (cryptol.exe). The third component is+the display name to use in the context menu.+<p>+Why separate the specification of verbs from that of the extension?+Because an installer may want to install verbs/actions for file types+other than those which it installs, e.g., if you're packaging up a PDF+manipulation tool, you'd probably want to register actions that invoke+your tool when right-clicking on .pdf files.+<p>+In case you want the user to fill in registration details upon+install, set 'userRegistration' to True:++<pre>+> +> userRegistration :: Bool+> userRegistration = False+>+</pre>++If you do, the edit fields that the user fills in are available via+the 'USERNAME', 'COMPANYNAME', and 'PIDKEY' properties.+<p>+You can optionally require the user to agree with your product's+license upon installing by making 'license' point to a RTF file+containing the license text:++<pre>+> +> license :: InstallEnv -> Maybe FilePath+> license _ienv = Nothing+> +</pre>++By default, your product will be installed locally in the 'Program+files' folder (in the 'pkg.title' folder.) To override this and+insist on a different default location, use 'defaultInstallFolder':++<pre>+> +> defaultInstallFolder :: Maybe FilePath+> defaultInstallFolder = Nothing+>+</pre>++For instance, GHC uses this option to good effect to encourage the+user to install this in the 'ghc' folder on the root drive,++<pre>+> +> defaultInstallFolder = Just $ "[WindowsVolume]ghc\\"++ghcVersion+> +</pre>++where 'WindowsVolume' is a property that expands to the name of the+drive holding your windows installation, e.g., "c:\\".+<p>+After having installed the product, the standard UI displays a final+dialog where the user has to click 'Finish' to complete the joyous+process. Should you want to override the rather bland text that is+included in that dialog, use 'finalMessage':++<pre>+>+> finalMessage :: Maybe String+> finalMessage = Just "Please remember to add [TARGETDIR]bin to your PATH."+> +</pre>++where 'TARGETDIR' is expanded by the installer to the location where+the user ended up putting the product.+<p>+It's often worthwhile to offer the user the alternative of being able+to install your product without requiring the user to have+Administrative privileges on his/her machine. To enable this, set+'userInstall' to True:++<pre>+> +> userInstall :: Bool+> userInstall = True+> +</pre>++which causes the installer UI to include a dialog that lets the user+select between a user-only and a machine-wide installation.+<p>+The Windows Installer framework provides special support for+installing and configuring Windows Services -- if your product+contains one or more of these, include a non-empty list when defining+'services':++<pre>+>+> services :: [Service]+> services = []+> +</pre>++ToDo: include Service data type + explanation+<p>++To give GHC users a helping hand in distributing packages, 'bamse'+provides special support for installing GHC packages. To make use of+it, define the properties of the package via the 'ghcPackageInfo'+definition:++<pre>+> +> ghcPackageInfo :: Maybe GhcPackage+> ghcPackageInfo = Nothing+> +</pre>++And last, but not least, to specify which files are to be included inb+your installer by supplying a definition of a 'dirTrees' function:++<pre>+> +> dirTree :: InstallEnv -> IO DirTree+> dirTree ienv = Util.Dir.findFiles ofInterest (srcDir ienv)+> where+> ofInterest file = not (last file == '~') &&+> not (baseName file == "CVS")+> +</pre>++Given the path to the directory containing the files we want to+distribute with Cryptol, we include all files except CVS directories+and backup files.+<p>+Sometimes the directory tree returned by 'dirTree' isn't equal to the+directory tree you want to install them as. Rather than force the+installer user to manually create an install tree layout that matches,+you can specify the translation via a 'distFileMap' function:++<pre>+> +> distFileMap :: Maybe (FilePath -> Maybe FilePath)+> distFileMap = Nothing+> +</pre>++If not equal to 'Nothing', the distFileMap will be applied to each+file and directory in the 'DirTree' returned by 'dirTree'. The result+is where that particular file/directory is to be put inside the+installed directory tree. If the entity isn't after all to be included+in the distribution, the 'distFileMap' function simply return Nothing.+<p>+Experimental support for nested installaters (i.e., MSIs containing+other MSIs) are provided via 'nestedInstalls' defn. This doesn't apply+to Cryptol, so its definition is the empty list:++<pre>+> +> nestedInstalls :: [(String, String)]+> nestedInstalls = []+> +</pre>++[For an example of how 'nestedInstalls' can be use, have a look at the+installer for Bamse itself, templates/Bamse.hs+]++<h2>API Summary</h2>++To summarise, a template module needs to export the following+signature:++<pre>+> module PackageSrc+> ( defaultOutFile -- :: FilePath+> , pkg -- :: Package+> , webSite -- :: String+> , bannerBitmap -- :: InstallEnv -> Maybe FilePath+> , bgroundBitmap -- :: InstallEnv -> Maybe FilePath+> , registry -- :: [RegEntry]+> , baseFeature -- :: Feature+> , features -- :: [Feature]+> , startMenu -- :: InstallEnv -> (String, [Shortcut])+> , desktopShortcuts -- :: InstallEnv -> [Shortcut]+> , extensions -- :: InstallEnv -> [Extension]+> , verbs -- :: [Extension]+> , license -- :: InstallEnv -> Maybe FilePah+> , userRegistration -- :: Bool+> , defaultInstallFolder -- :: Maybe String+> , dirTree -- :: InstallEnv -> IO DirTree+> , distFileMap -- :: Maybe (FilePath -> Maybe FilePath)+> , featureMap -- :: Maybe (FilePath -> FeatureName)+> , finalMessage -- :: Maybe String+> , userInstall -- :: Bool+> , services -- :: [Service]+> , ghcPackageInfo -- :: Maybe GhcPackage+> , nestedInstalls -- :: [(String, Maybe String)]+> ) where+</pre>++<hr>+<address>+<a href="http://www.galois.com/~sof/">sof</a>+</address>+<!-- hhmts start --> Last modified: Fri Sep 17 21:42:52 Pacific Standard Time 2004 <!-- hhmts end -->+</body> </html>
+ doc/using.txt view
@@ -0,0 +1,515 @@+* Creating Windows Installers+=============================++This is the user guide for a tool that tries to assist you in creating+Microsoft Windows installers. It lets you put together installer+builders for your application/library/tool, builders that can then be+used to automate the actual rolling up of shippable Windows+Installers. The tool uses Haskell to tailor the general installer+framework to the needs of your application's installation story.++Enough content-free verbiage -- let's get concrete and look at how to+author your own installer builders.++* Getting started+=================++The easiest way to get started is to look at existing installer+templates, and try to tailor these to fit; see the templates/+directory. 'bamse' uses Haskell as the specification language for+these templates, requiring the user to supply a Haskell module that+exports a collection of functions and values that define the+characteristics of an installer builder. Using an existing programming+language for this rather than invent some custom input format/schema to+specify the behaviour and contents of an installer has some+merit. It is still an open issue whether or not the power of a+programming language is required though, and something we hope to+better understand by specifying a number of installer builders.++Using the Cryptol template as our example, let's do a walkthrough of+its installation template module (we're assuming that you're vaguely+familiar with Haskell syntax):++> module Cryptol where +>+> import Bamse.Package; import Bamse.PackageUtils+>+> import Data.List ( intersperse )+> import Util.Dir ( DirTree(..), findFiles )+> import Util.Path ( baseName )+> ++All installer builder template import the 'Bamse.Package' and 'Bamse.PackageUtils'+modules to bring into scope various types and utility functions. In+addition to these, the Cryptol template requires some list and directory/path +processing functions; the former is imported from a standard Haskell+module, the latter from the Galois Haskell library. OK, first some+helper definitions:++> +> pkgName, pkgVersion :: String+> pkgName = "Cryptol"+> pkgVersion = "1.4"+>++While neither 'pkgName' nor 'pkgVersion' are used outside of this+template module, abstracting them out as local definitions is handy.++> -- what to output the MSI as if no -o option is given.+> defaultOutFile = PackageUtils.toMsiFileName (pkgName ++ '-':pkgVersion)+> ++The 'bamse' tool supports a standard set of command-line options, one+of which is the name of the file the builder should output the+installer as. In the event the user doesn't supply this option,+'defaultOutFile' is used. To make sure we don't run afoul MSI+restrictions on filenames, 'PackageUtils.toMsiFileName' is used to+translate the default filename into a valid MSI filename.++> -- 'information summary stream' data bundled up together.+> pkg :: Package+> pkg = Package+> { name = pkgName+> , title = pkgName ++ ", version " ++ pkgVersion+> , productVersion = "1.4.2.0"+> , author = "Galois Connections, Inc."+> , comment = unwords [pkgName, "Version", pkgVersion]+> }++The next definition collects together informational data about the+installer you're creating a builder for. The Package.Package data type+is defined as follows:++> data Package+> = Package { +> name :: String+> -- ^ The name of the product which the installer provides.+> , title :: String+> -- ^ Brief description of installer contents.+> , productVersion :: String+> -- ^ productVersion format:+> -- major.minor.build[.whatever]+> -- +> , author :: String+> -- ^ name of manufacturer of the installer+> , comment :: String+> -- ^ short text describing purpose of installer+> }++The meaning of these individual fields are hopefullly self-evident.++The URL associated with a product is given via the 'webSite'+definition:++>+> webSite :: String+> webSite = "http://www.cryptol.net/"+> ++Currently, this URL is only used when specifying the 'help URL'+associated with an installer.++Customisation of an installer's UI is possible in a number of ways;+you can for instance specify the bitmaps to use as backdrop and a+banner: ++> +> bannerBitmap :: InstallEnv -> Maybe FilePath+> bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner3.bmp")+> +> bgroundBitmap :: InstallEnv -> Maybe FilePath+> bgroundBitmap ienv = Just (lFile (toolDir ienv) "art/bground2.bmp")+> ++These are specified as functions, taking an 'InstallEnv' describing+the context the installer is invoked from. The 'toolDir' field of+an 'InstallEnv' specifies the toplevel directory of the installer+builder tool itself. It it used here to get hold of some standard+bitmaps without having to hardwire their paths into the template.+If you simply want to use the standard UI, have both of these +functions return 'Nothing'.++The 'InstallEnv' type is defined as follows:++> data InstallEnv+> = InstallEnv +> { toolDir :: FilePath -- ^ where installer tool lives +> , srcDir :: FilePath -- ^ path to toplevel directory of files to be distributed.+> , dataDir :: FilePath -- ^ user-supplied path to directory containing installer+> -- template specific files.+> }++The 'dataDir' field holds the path to a directory which contains files+particular to all installers for your product; for instance, instead+of using 'toolDir' above to get hold of bitmap files, 'dataDir' could+be used to get hold of Cryptol specific distribution/installer+files. The 'srcDir' directory points to the top of the directory tree+you want to package up.++Some products require the use of the Registry to store installation+specific data in order to operate properly. To specify what actions+the installer should perform upon the Registry upon installation (and+un-installation), the 'registry' list is used:++> +> registry :: [RegEntry]+> registry = cryptolSettings ++ haskellProject "Cryptol" [....]+> ++In the case of Cryptol, it consists of two parts, one to setup the+Cryptol-specific Registry data, the other to integrate Cryptol with+your the Haskell interpreter Hugs98. For grubby Hugs versioning+issues, the setup of the latter is a little bit involved, so let's+focus on the Cryptol-specific options only (see the real template+module for complete details.)++>+> cryptolSettings = +> [ RegEntry "HKCU" "Software" (CreateKey False)+> , RegEntry "HKCU" "Software\\Cryptol" (CreateKey True)+> , RegEntry "HKCU" "Software\\Cryptol" (CreateName (Just "Options") "")+> , RegEntry "OnInstall" "Software" (CreateKey False)+> , RegEntry "OnInstall" "Software\\Cryptol" (CreateKey True)+> , RegEntry "OnInstall" "Software\\Cryptol" (CreateName (Just "InstallDir") "[TARGETDIR]")+> ]+> ++Each 'RegEntry' consists of three fields; the first specifies the hive+(Registry lingo for the toplevel directory/key), the second the path+to the key/value to install within that hive. Notice the use of the+'OnInstall' hive here; it is a meta-hive name which is used to specify+Registry data that is supposed to go into either the machine or+user-specific portion/hive of the Registry. Which one is decided when+when the user installing the software picks a per-machine or a+per-user installation.++The third argument to RegEntry specifies what action to perform on the +given Registry key/value -- it is defined as follows:++> +> data KeyAction+> = CreateKey Bool -- True => delete on uninstall+> | CreateName (Maybe String) -- Just x => default name for the name.+> String+> | DeleteKey Bool -- True => remove key on _install_+> -- False => remove key on _uninstall_+> | DeleteName Bool String -- True => remove name on _install_+> -- False => remove name on _uninstall_+> ++You'll be using the first two constructors most of the time to+hygenically install and un-install Registry entries for your product;+'cryptolSettings' doing just this for Cryptol, being a good citizen+by deleting its Registry tree when the application is uninstalled.++Next item on the list of things a template needs to provide is the+specification of 'features': an installer can partition the files it+distributes into a set of features, each of which the user can decide+whether or not to install locally. The root or base feature is+specified via 'baseFeature':++> baseFeature :: Feature+> baseFeature = (baseFeatureName, pkgName ++ '-':pkgVersion)+> +> baseFeatureName :: String+> baseFeatureName = pkgName+> +> features :: [Feature]+> features = [baseFeature]++Associated with the base feature are all essential files of your+product + installer features such as start menu entries, desktop+shortcuts, registry entries etc. The base feature is unique in that+the user cannot opt not to install it. The other features, specified+via 'features', can be de-selected at install-time by the user.+[Note: it is currently not possible to associate files/directories+with other features than 'baseFeature', making 'features' rather+useless as-is. Only thing it gives you is an selectable option on the+customised-install dialog.]++Integrating your product into the Windows graphical shell is supported+in a number of ways: start menu entries, desktop shortcuts, custom+filetypes and the definition of operations over these custom files.+Start menu items are defined via 'startMenu':++>+> startMenu :: InstallEnv -> (String, [Shortcut])+> startMenu ienv = (pkgName, shortcuts ienv)+> ++In dictatorial fashion, 'bamse' will only let you install start menu+items in a separate folder inside the programs folder. The first+component of the 'startMenu's result pair is the folder to create (and+delete upon uninstall) -- sub-folders are created by specifying a+relative path here, e.g., "Cryptol/version1.4" (see the GHC template+for an example of this.) The second component contain the shortcuts+you want to have appear in that menu. The 'Shortcut' data type is+defined as follows:++> +> data Shortcut+> = Shortcut+> { scut_name :: String -- name+> , scut_target :: String -- target app+> , scut_args :: String -- arguments+> , scut_desc :: String -- description+> , scut_icon :: Maybe FilePath -- icon file+> , scut_istate :: Int -- initial state+> , scut_wdir :: String -- working dir.+> }+>++The fields are best explained via an actual example:++> shortcuts :: InstallEnv -> [Shortcut]+> shortcuts ienv =+> [ Shortcut "Cryptol interpreter"+> (lFile topDir "bin\\cryptol.exe")+> ""+> "Cryptol interpreter"+> (Just (lFile iconDir "cry.exe"))+> 1+> "[TARGETDIR]"+> ]+> where+> topDir = srcDir ienv+> iconDir = lFile (toolDir ienv) "icons"++The first component is the display name of the shortcut, the second+is the target file of the shortcut -- here, the binary of the Cryptol+interpreter. The third argument contain any command-line arguments to+pass the target, the fourth is the descriptive text (i.e., verbiage that+shows up when you hold the mouse cursor over the item). Next is the+icon to associate with the shortcut; -- see section Foo on details on+how to create your icon files -- here, the icon is the "standard"+Cryptol icon that comes bundled with 'bamse'. The second to last field+control how to initially show the shortcut application once launched;+1 meaning show a normal window (3 = show maximized; 7=show minimized.)+The last field is the initial working directory of the launched+application -- "[TARGETDIR]" is a meta-directory name that gets+expanded by the Microsoft Installer Runtime to the directory where the+product ended up being installed locally.++Note: if you don't want a start menu folder installed with your+product, simply leave 'startMenu's shortcut list as empty.++The Shortcut data type is naturally also used when specifying desktop+shortcuts:++> +> desktopShortcuts :: InstallEnv -> [Shortcut]+> desktopShortcuts ienv = shortcuts ienv+> ++Making Cryptol install both a start menu and desktop shortcut to its+interpreter.++To further embed your product into the Windows shell, you have the+option of registering custom filename extensions + actions to perform+support over these:++>+> extensions :: InstallEnv -> [ Extension ]+> extensions ienv = [ cryptolExtension (srcDir ienv (toolDir ienv) "cry" ]+> ]++The '.cry' file extension is here associated with the Cryptol interpreter,++> cryptolExtension :: FilePath -> FilePath -> String -> Extension+> cryptolExtension topDir toolDir ext +> = ( "CryptolFile" -- (unique) extension label+> , lFile topDir "bin\\cryptol.exe"+> , lFile iconDir "cry.exe"+> , ext+> )+> where+> iconDir = lFile toolDir "icons"+> ++together with the icon contained in the 'cry.exe' resource+binary. Operations on this file type is specified via the 'verbs'+definition:++> verbs :: [ ( String -- extension+> , String -- verb+> , String -- label+> , String -- arguments+> )+> ]+> verbs = [ ( "cry"+> , "open"+> , "&Open"+> , "\"%1\"")]+> ++The standard 'open' action is here defined to pass the file path of+the opened/double-clicked .cry file as command-line argument to the +application associated with it (cryptol.exe). The third component is+the display name to use in the context menu.++Why separate the specification of verbs from that of the extension?+Because an installer may want to install verbs/actions for file types+other than those which it installs, e.g., if you're packaging up a PDF+manipulation tool, you'd probably want to register actions that invoke+your tool when right-clicking on .pdf files.++In case you want the user to fill in registration details upon+install, set 'userRegistration' to True:++> +> userRegistration :: Bool+> userRegistration = False+>++If you do, the edit fields that the user fills in are available via+the 'USERNAME', 'COMPANYNAME', and 'PIDKEY' properties.++You can optionally require the user to agree with your product's+license upon installing by making 'license' point to a RTF file+containing the license text:++> +> license :: InstallEnv -> Maybe FilePath+> license _ienv = Nothing+> ++By default, your product will be installed locally in the 'Program+files' folder (in the 'pkg.title' folder.) To override this and+insist on a different default location, use 'defaultInstallFolder':++> +> defaultInstallFolder :: Maybe FilePath+> defaultInstallFolder = Nothing+>++For instance, GHC uses this option to good effect to encourage the+user to install this in the 'ghc' folder on the root drive,++> +> defaultInstallFolder = Just $ "[WindowsVolume]ghc\\"++ghcVersion+> ++where 'WindowsVolume' is a property that expands to the name of the+drive holding your windows installation, e.g., "c:\\".++After having installed the product, the standard UI displays a final+dialog where the user has to click 'Finish' to complete the joyous+process. Should you want to override the rather bland text that is+included in that dialog, use 'finalMessage':++>+> finalMessage :: Maybe String+> finalMessage = Just "Please remember to add [TARGETDIR]bin to your PATH."+> ++where 'TARGETDIR' is expanded by the installer to the location where+the user ended up putting the product.++It's often worthwhile to offer the user the alternative of being able+to install your product without requiring the user to have+Administrative privileges on his/her machine. To enable this, set+'userInstall' to True:++> +> userInstall :: Bool+> userInstall = True+> ++which causes the installer UI to include a dialog that lets the user+select between a user-only and a machine-wide installation.++The Windows Installer framework provides special support for+installing and configuring Windows Services -- if your product+contains one or more of these, include a non-empty list when defining+'services':++>+> services :: [Service]+> services = []+> ++ToDo: include Service data type + explanation++To give GHC users a helping hand in distributing packages, 'bamse'+provides special support for installing GHC packages. To make use of+it, define the properties of the package via the 'ghcPackageInfo'+definition:++> +> ghcPackageInfo :: Maybe GhcPackage+> ghcPackageInfo = Nothing+> ++And last, but not least, to specify which files are to be included inb+your installer by supplying a definition of a 'dirTrees' function:++> +> dirTree :: InstallEnv -> IO DirTree+> dirTree ienv = Util.Dir.findFiles ofInterest (srcDir ienv)+> where+> ofInterest file = not (last file == '~') &&+> not (baseName file == "CVS")+> ++Given the path to the directory containing the files we want to+distribute with Cryptol, we include all files except CVS directories+and backup files.++Sometimes the directory tree returned by 'dirTree' isn't equal to the+directory tree you want to install them as. Rather than force the+installer user to manually create an install tree layout that matches,+you can specify the translation via a 'distFileMap' function:++> +> distFileMap :: Maybe (FilePath -> Maybe FilePath)+> distFileMap = Nothing+> ++If not equal to 'Nothing', the distFileMap will be applied to each+file and directory in the 'DirTree' returned by 'dirTree'. The result+is where that particular file/directory is to be put inside the+installed directory tree. If the entity isn't after all to be included+in the distribution, the 'distFileMap' function simply return Nothing.++Experimental support for nested installaters (i.e., MSIs containing+other MSIs) are provided via 'nestedInstalls' defn. This doesn't apply+to Cryptol, so its definition is the empty list:++> +> nestedInstalls :: [(String, String)]+> nestedInstalls = []+> ++[For an example of how 'nestedInstalls' can be use, have a look at the+installer for Bamse itself, templates/Bamse.hs+]++To summarise, a template module needs to export the following+signature:++> module PackageSrc+> ( defaultOutFile -- :: FilePath+> , pkg -- :: Package+> , webSite -- :: String+> , bannerBitmap -- :: InstallEnv -> Maybe FilePath+> , bgroundBitmap -- :: InstallEnv -> Maybe FilePath+> , registry -- :: [RegEntry]+> , baseFeature -- :: Feature+> , features -- :: [Feature]+> , startMenu -- :: InstallEnv -> (String, [Shortcut])+> , desktopShortcuts -- :: InstallEnv -> [Shortcut]+> , extensions -- :: InstallEnv -> [Extension]+> , verbs -- :: [Extension]+> , license -- :: InstallEnv -> Maybe FilePah+> , userRegistration -- :: Bool+> , defaultInstallFolder -- :: Maybe String+> , dirTree -- :: InstallEnv -> IO DirTree+> , distFileMap -- :: Maybe (FilePath -> Maybe FilePath)+> , featureMap -- :: Maybe (FilePath -> FeatureName)+> , finalMessage -- :: Maybe String+> , userInstall -- :: Bool+> , services -- :: [Service]+> , ghcPackageInfo -- :: Maybe GhcPackage+> , nestedInstalls -- :: [(String, Maybe String)]+> ) where+
+ icons/cmdIcon.exe view
binary file changed (absent → 25088 bytes)
+ icons/folder.exe view
binary file changed (absent → 83249 bytes)
+ icons/hs.exe view
binary file changed (absent → 2048 bytes)
+ icons/hsx.exe view
binary file changed (absent → 2048 bytes)
+ icons/html.exe view
binary file changed (absent → 12288 bytes)
+ icons/html2.exe view
binary file changed (absent → 27136 bytes)
+ icons/pdf.exe view
binary file changed (absent → 13312 bytes)
+ icons/star.exe view
binary file changed (absent → 31744 bytes)
+ icons/txt.exe view
binary file changed (absent → 4096 bytes)
+ license.rtf view
binary file changed (absent → 1816 bytes)
+ templates/Alex.hs view
@@ -0,0 +1,129 @@+--+-- (c) 2007, Galois, Inc.+--+-- To create a package, you need to define a module+-- which exports information and functions that together+-- define the functionality (and contents) of your package.+--+-- [Having Haskell as the only 'specification language' for packages+-- is not a goal. ]+module Alex where++import Data.List++import Util.Dir+import Util.Path+import Util.List+import Bamse.Package+import Bamse.PackageUtils++pkgName = "alex"+pkgVersion = "2.01"+pkgDoc = "doc\\alex\\alex.html"++defaultOutFile = toMsiFileName pkgName++pkg :: Package+pkg = Package+ { name = pkgName+ , title = pkgName+ , productVersion = "2.0.1.0"+ , author = "Simon Marlow"+ , comment = unwords [pkgName, "Version", pkgVersion]+ }++webSite :: String+webSite = "http://haskell.org/alex"++bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner.bmp")++bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap _ienv = Nothing++{-+ The installer needs to record the following in the Registry:+ * the location of the installation directory.+ -- used by the Cryptol interpreter to set up the Cryptol+ import path when invoking GHC.+ * Cryptol as a Hugs 'project' -- requires the addition of+ a (large) set of directories to the search path.+-}+registry :: [RegEntry]+registry + = []++features :: [Tree Feature]+features = [ Leaf baseFeature ]++baseFeatureName :: String+baseFeatureName = pkgName++baseFeature :: Feature+baseFeature = (baseFeatureName, pkgName ++ '-':pkgVersion)++startMenu :: InstallEnv -> (String, [Shortcut])+startMenu ienv = (pkgName, entries)+ where+ iconDir = lFile (toolDir ienv) "icons"++ entries :: [Shortcut]+ entries = + [ Shortcut "Alex user manual"+ (lFile (srcDir ienv) pkgDoc)+ ""+ "Alex documentation"+ (Just (lFile iconDir "html.exe"))+ 1+ "[TARGETDIR]"+ ]++desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts _ienv = []++extensions :: InstallEnv -> [ Extension ]+extensions _ienv = []++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = [ ]++dirTree :: InstallEnv -> IO DirTree+dirTree ienv = findFiles ofInterest (srcDir ienv)+ where+ ofInterest file = not (last file == '~') &&+ not (baseName file == "CVS")+ +distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing++featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++license :: InstallEnv -> Maybe FilePath+license _ienv = Nothing++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder + = Just $ "[WindowsVolume]"++pkgName++'\\':pkgName++'-':pkgVersion++finalMessage :: Maybe String+finalMessage = Nothing++userInstall :: Bool+userInstall = False++services :: [Service]+services = []++ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Nothing++nestedInstalls = []
+ templates/Bamse.hs view
@@ -0,0 +1,167 @@+--+-- Specification/template for the Bamse tool itself.+--+-- (c) 2007, Galois, Inc.+--+module Bamse where++import Bamse.Package+import Bamse.PackageUtils++import Util.Dir ( DirTree(..), findFiles )+import Util.Path ( baseName, dirname, fileSuffix )+import Debug.Trace++pkgName = "bamse"+pkgVersion = "1.0"++-- what to output the MSI as if no -o option is given.+defaultOutFile = toMsiFileName (pkgName ++ '-':pkgVersion)++-- 'information summary stream' data bundled up together.+pkg :: Package+pkg = Package+ { name = pkgName+ , title = pkgName ++ ", version " ++ pkgVersion+ , productVersion = "1.0.0.0"+ , author = "Galois, Inc."+ , comment = unwords [pkgName, "Version", pkgVersion]+ }++webSite :: String+webSite = "http://www.galois.com/"++bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner3.bmp")++bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap ienv = Just (lFile (toolDir ienv) "art/bground2.bmp")++registry :: [RegEntry]+registry = []++baseFeatureName :: String+baseFeatureName = pkgName++baseFeature :: Feature+baseFeature = (baseFeatureName, pkgName ++ '-':pkgVersion)++features :: [Tree Feature]+features = [ Leaf baseFeature ]++startMenu :: InstallEnv -> (String, [Shortcut])+startMenu ienv = (pkgName, shortcuts ienv)++shortcuts :: InstallEnv -> [Shortcut]+shortcuts ienv = + [ Shortcut "Bamse installer"+ (lFile (srcDir ienv) "doc/index.html")+ ""+ "Bamse installer"+ (Just (lFile iconDir "html.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "Using Bamse"+ (lFile (srcDir ienv) "doc/using.html")+ ""+ "Using bamse"+ (Just (lFile iconDir "html.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "Getting started"+ (lFile (srcDir ienv) "doc/howto.html")+ ""+ "Getting started"+ (Just (lFile iconDir "html.exe"))+ 1+ "[TARGETDIR]"+ ]+ where+ iconDir = lFile (toolDir ienv) "icons"++desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts ienv = []++extensions :: InstallEnv -> [ Extension ]+extensions ienv = []++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = []++license :: InstallEnv -> Maybe FilePath+license ienv = Just (lFile (toolDir ienv) "license.rtf")++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder = Nothing++dirTree :: InstallEnv -> IO DirTree+dirTree ienv = findFiles ofInterest' (srcDir ienv)+ where+ ofInterest' f = + if ofInterest f + then trace ("including:" ++ f) True+ else trace ("excluding:" ++ f ++ show (dirname f)) False++ ofInterest file = {-trace ("considering: " ++ show (dirname fileRel, fileRel)) $ -} not $+ emacsCVSMeta fileRel ||+ fileRel `elem` [ ".cvsignore", "TODO" ] ||+ fileRel `elem` ["out", "output", "packages", "libraries", "soe"] ||+ (dirname fileRel == "." && fileSuffix fileRel == "log") ||+ (dirname fileRel == "." && fileSuffix fileRel == "msi") ||+ (dirname fileRel == "." && fileSuffix fileRel == "exe") ||+ (dirname fileRel == "." && fileSuffix fileRel == "a") ||+ fileSuffix fileRel `elem` ["o", "obj", "hi"]+ where+ fileRel = dropDirPrefix (srcDir ienv) file+ emacsCVSMeta f = + case baseName f of+ '#':_ -> True+ '.':'#':_ -> True+ "CVS" -> True+ _ -> not (null f) && last f == '~'++distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing++-- if provided, a mapping from dist tree filename to the+-- the feature it belongs to. If Nothing, all files are+-- mapped to the base feature.+featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++finalMessage :: Maybe String+finalMessage = Nothing++userInstall :: Bool+userInstall = True++services :: [Service]+services = []++ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Nothing++-- nested installations are supported via sub-storage only.+-- i.e., after having built the Bamse installer, you need+-- to do the following:+-- +-- foo$ msidb -d bamse.msi -r com.msi+-- foo$ msidb -d bamse.msi -r galois.msi+-- +-- where 'msidb' is the tool that comes with the MS Platform SDK.+-- +nestedInstalls :: [(FilePath, Maybe String)]+nestedInstalls = []+{- painful to work with, disable.+ [ ("com.msi", Nothing) + , ("galois.msi", Nothing) + ]+-}
+ templates/Base.hs view
@@ -0,0 +1,122 @@+--+-- (c) 2007, Galois, Inc.+--+-- Installer builder template; please copy and modify.+--+-- To create your own installer, you need to supply a Haskell module+-- which exports the functions and values below.+--+module Base+ -- for informational purposes, here's the exports + -- the Bamse infrastructure expects:+ ( defaultOutFile -- :: FilePath+ , pkg -- :: Package+ , webSite -- :: String+ , bannerBitmap -- :: InstallEnv -> Maybe FilePath+ , bgroundBitmap -- :: InstallEnv -> Maybe FilePath+ , registry -- :: [RegEntry]+ , baseFeature -- :: Feature+ , features -- :: [Tree Feature]+ , startMenu -- :: InstallEnv -> (String, [Shortcut])+ , desktopShortcuts -- :: InstallEnv -> [Shortcut]+ , extensions -- :: InstallEnv -> [Extension]+ , verbs -- :: [Extension]+ , license -- :: InstallEnv -> Maybe FilePah+ , userRegistration -- :: Bool+ , defaultInstallFolder -- :: Maybe String+ , dirTree -- :: InstallEnv -> IO DirTree+ , distFileMap -- :: Maybe (FilePath -> Maybe FilePath)+ , featureMap -- :: Maybe (FilePath -> FeatureName)+ , finalMessage -- :: Maybe String+ , userInstall -- :: Bool+ , services -- :: [Service]+ , ghcPackageInfo -- :: Maybe GhcPackage+ , nestedInstalls -- :: [(String, Maybe String)]+ ) where++import Bamse.Package+import Bamse.PackageUtils+import Util.Dir ( DirTree, GenDirTree(..) )++appName = "myapp"++defaultOutFile = toMsiFileName appName++pkg :: Package+pkg = Package+ { name = appName+ , title = "title cannot be empty"+ , productVersion = "0.1.0"+ , author = "SomeRandomCorp"+ , comment = "Example MSI installer template"+ }++webSite :: String+webSite = "http://self-promo.org/"++bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap _ienv = Nothing++bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap _ienv = Nothing++registry :: [RegEntry]+registry = []++baseFeatureName :: FeatureName+baseFeatureName = "MyApp"++baseFeature :: Feature+baseFeature = (baseFeatureName, "Example MSI installer template")++features :: [Tree Feature]+features = [Leaf baseFeature]++startMenu :: InstallEnv -> (String, [Shortcut])+startMenu _ienv = (baseFeatureName, [])++desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts ienv = []++extensions :: InstallEnv -> [ Extension ]+extensions ienv = [ ]++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = []++dirTree :: InstallEnv -> IO DirTree+dirTree _ienv = return Empty++distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing++featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++license :: InstallEnv -> Maybe FilePath+license ienv = Nothing++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder = Nothing++finalMessage :: Maybe String+finalMessage = Nothing++userInstall :: Bool+userInstall = False++services :: [Service]+services = []++ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Nothing++nestedInstalls = []
+ templates/ComPkg.hs view
@@ -0,0 +1,157 @@+--+-- (c) 2007, Galois, Inc.+--+-- To create a package, you need to define a module+-- which exports information and functions that together+-- define the functionality (and contents) of your package.+--+-- [Having Haskell as the only 'specification language' for packages+-- is not a goal. ]+module ComPkg where++import Util.Dir+import Util.Path+import Bamse.Package+import Bamse.PackageUtils+import Debug.Trace++versionNumber = "0.30"+libVersion = "comlib-" ++ versionNumber+defaultOutFile = toMsiFileName libVersion+packageName="comLib"++pkg :: Package+pkg = Package+ { name = "comlib"+ , title = "COM support library for GHC-" ++ forGhcVersion+ , productVersion = "1.0.0.0"+ , author = "Sigbjorn Finne"+ , comment = "Version: " ++ versionNumber+ }++webSite :: String+webSite = "http://haskell.org/hdirect"++bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner.bmp")++bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap _ienv = Nothing++registry :: [RegEntry]+registry = []++features :: [Tree Feature]+features = [ Leaf baseFeature ]++baseFeatureName :: String+baseFeatureName = "comlib"++baseFeature :: Feature+baseFeature = (baseFeatureName, "COM library for GHC")++startMenu :: InstallEnv -> (String, [Shortcut])+startMenu ienv = ("GHC/packages/"++packageName, entries)+ where+ entries :: [Shortcut]+ entries = + [ Shortcut "Documentation (HTML)"+ (lFile (srcDir ienv) "doc\\index.html")+ ""+ "Library documentation"+ (Just (lFile iconDir "html.exe"))+ 1+ "[TARGETDIR]"+ ]++ iconDir = toolDir ienv ++ "\\icons"++desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts _ienv = []++extensions :: InstallEnv -> [ Extension ]+extensions _ienv = [ ]++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = []++dirTree :: InstallEnv -> IO DirTree+dirTree ienv = findFiles ofInterest' (srcDir ienv)+ where+ ofInterest' f = + if ofInterest f + then trace ("including:" ++ f) True+ else trace ("excluding:" ++ f ++ show (dirname f)) False++ -- Note: 'path' is prefixed by 'topDir'.+ ofInterest path + = path == srcDir ienv+-- || ("System" `elem` splitPath path && not ("tmp" `elem` splitPath path))+ || baseName path `elem` ["com.pkg", "HScom.o", "doc", "include", "cbits"]+ || baseName path == "doc" || baseName (dirname path) == "doc"+ || baseName path == "build" || baseName (dirname path) == "build"+ || fileSuffix path `elem` [{-"",-} "a", "hi", "h", "hs"]+ || not (emacsCVSMeta path || fileSuffix path `elem` ["raw-hs"])+ -- By leaving out "", we won't recurse into subdirs. We specially+ -- check for the toplevel directory, as it needs to be present.+-- (fileSuffix file `elem` [""{-directory-}, "dll", "hs", "lhs", "idl", "h", "pkg"])+ + emacsCVSMeta f = + case baseName f of+ '#':_ -> True+ '.':'#':_ -> True+ "CVS" -> True+ ".cvsignore" -> True+ _ -> not (null f) && last f == '~'+++distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing++featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++license :: InstallEnv -> Maybe FilePath+license _ienv = Nothing++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder = Just $ "[WindowsVolume]ghc\\packages\\ghc-"++forGhcVersion ++ "\\" ++ packageName ++ "\\"++forGhcVersion :: String+forGhcVersion = "6.6.1"++finalMessage :: Maybe String+finalMessage = Nothing++userInstall :: Bool+userInstall = False++services :: [Service]+services = []++ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Just $+ GhcPackage { ghc_packageName = "Com"+ -- ToDo: allow 'most-recent' compiler to be used.+ , ghc_forVersion = forGhcVersion+ , ghc_packageFile = Just "com.pkg"+ , ghc_pkgCmdLine = Just (unwords [ def "hd_lib" ""+ , def "hd_imp" "build"+ , def "hd_inc" "include"+ ])+ }+ where+ tgt "" = "\"[TARGETDIR]build\""+ tgt s = "\"[TARGETDIR]" ++ s ++ "\""+ + def s v = '-':'D':s ++ '=':tgt v+ +nestedInstalls = []
+ templates/Cryptol.hs view
@@ -0,0 +1,260 @@+--+-- (c) 2007, Galois, Inc.+--+-- Specification/template for the Cryptol installer builder.+--+-- To create your own installer, you need to supply a Haskell module+-- which exports functions and values that together define the+-- functionality (and contents) of your package;+-- see Base.hs just what those exports are.+--+module Cryptol where++import Bamse.Package+import Bamse.PackageUtils++import Data.List ( intersperse )+import Util.Dir ( DirTree(..), findFiles )+import Util.Path ( baseName )+import Util.List ( concatWith )++pkgName = "Cryptol"+pkgVersion = expandString "$<VERSION:1.5>"++-- what to output the MSI as if no -o option is given.+defaultOutFile = toMsiFileName (pkgName ++ '-':pkgVersion)++-- 'information summary stream' data bundled up together.+pkg :: Package+pkg = Package+ { name = pkgName+ , title = pkgName ++ ", version " ++ pkgVersion+ , productVersion = "1.0.0.0"+ , author = "Galois Connections, Inc."+ , comment = unwords [pkgName, "Version", pkgVersion]+ }++webSite :: String+webSite = "http://www.cryptol.net/"++bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner3.bmp")++bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap ienv = Just (lFile (toolDir ienv) "art/bground2.bmp")++{-+ The installer needs to record the following in the Registry:+ * the location of the installation directory.+ -- used by the Cryptol interpreter to set up the Cryptol+ import path when invoking GHC.+ * Cryptol as a Hugs 'project' -- requires the addition of+ a (large) set of directories to the search path.+-}+registry :: [RegEntry]+registry + = cryptolSettings +++ haskellProject "Cryptol"+ [ ("hugsPath", (sepBy ';' [ tgt "src\\lib\\hugs"+ , tgt "src\\lib\\parsec"+ , tgt "src\\CSP\\lib"+ , tgt "src\\CSP\\lib\\hugs"+ , tgt "src\\lib\\misc"+ , tgt "src\\CSP\\Cryptol"+ ]))+ ] +++ -- ToDo: verify that this isn't required with Dec'01 of Hugs.+ -- (i.e., Hugs has had an upper limit on the length of 'hugsPath'.)+ haskellProject "CryptolExtras"+ [ ("hugsPath", (sepBy ';' [ tgt "src\\CSP\\Cryptol\\win32"+ , tgt "src\\lib\\misc\\win32"+ ]))+ ]+ where+ sepBy ch ls = concatWith ch ls+ tgt = ("[TARGETDIR]"++)++cryptolSettings = + -- ToDo: have the interpreter create these entries on-the-fly, if missing.+ -- => drop these entries.+ [ RegEntry "HKCU" "Software" (CreateKey False)+ , RegEntry "HKCU" "Software\\Cryptol" (CreateKey True)+ , RegEntry "HKCU" "Software\\Cryptol" (CreateName (Just "Options") "")+ ]+++baseFeatureName :: String+baseFeatureName = pkgName++baseFeature :: Feature+baseFeature = (baseFeatureName, pkgName ++ '-':pkgVersion)++features :: [Tree Feature]+features = [ Leaf baseFeature ]+{-+ , Leaf ("Test", "The test feature")+ , Node ("ParentTest", "A parent test feature")+ [ Leaf ("Child1", "A child feature")+ , Leaf ("Child2", "Another child feature")+ ]+ ]+-}++startMenu :: InstallEnv -> (String, [Shortcut])+startMenu ienv = (pkgName, shortcuts ienv)++shortcuts :: InstallEnv -> [Shortcut]+shortcuts ienv = + [ Shortcut "Cryptol interpreter"+ (lFile (srcDir ienv) "cryptol.exe")+ ""+ "Cryptol interpreter"+ (Just (lFile iconDir "cry.exe"))+ 1+ "[TARGETDIR]"+{- Example of how to specify directory shortcuts, the second arg giving the top-directory-relative+ directory name + assigning it the standard folder icon. + , Shortcut "Cryptol test directory"+ "tests"+ ""+ "Cryptol test directory"+ (Just (lFile iconDir "folder.exe"))+ 1+ "[TARGETDIR]"+ -}+ ]+ where+ iconDir = lFile (toolDir ienv) "icons"++desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts ienv = shortcuts ienv++extensions :: InstallEnv -> [ Extension ]+extensions ienv+ = [ cryptolExtension (srcDir ienv) (toolDir ienv) "cry"+ ]++cryptolExtension :: FilePath -> FilePath -> String -> Extension+cryptolExtension topDir toolDir ext + = ( "CryptolFile"+ , lFile topDir "cryptol.exe"+ , lFile iconDir "cry.exe"+ , ext+ )+ where+ iconDir = lFile toolDir "icons"++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = [ ( "cry"+ , "open"+ , "&Open"+ , "\"%1\""+ )+ ]++license :: InstallEnv -> Maybe FilePath+license _ienv = Nothing++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder = Nothing++dirTree :: InstallEnv -> IO DirTree+dirTree ienv = findFiles ofInterest (srcDir ienv)+ where+ ofInterest file = not (last file == '~') &&+ not (baseName file == "CVS") &&+ not (baseName file == "bin")+ +{- Older experiment in specifying a dist tree which differed+ from the source tree. Keep around as it might prove useful+ later on.+dirTree :: FilePath -> IO DirTree+dirTree = do + aes <- findFilesRel ofInterest (topDir ++ "\\build\\share\\galois\\AES")+ ex <- findFilesRel ofInterest (topDir ++ "\\build\\Examples")+ lib <- findFilesRel ofInterest (topDir ++ "\\build\\lib")+ csp <- findFilesRel ofInterest (topDir ++ "\\CSP")+ hs <- findFilesRel ofInterest (topDir ++ "\\Haskell")+ libr <- findFilesRel ofInterest (topDir ++ "\\lib")+ mk <- findFilesRel ofInterest (topDir ++ "\\mk")+ tst <- findFilesRel ofInterest (topDir ++ "\\CSP\\Cryptol\\tests")+ let+ dataTree = aes+ docTree = [ File (topDir ++ "\\CSP\\Documentation\\CheatSheet.doc")+ , File (topDir ++ "\\CryptolIntro.ps")+ , File (topDir ++ "\\CryptolIntro.tex")+ ]+ dslTree = [ File (topDir ++ "\\DSL\\Perms.hs")+ , File (topDir ++ "\\DSL\\Permute.hs")+ ]+ incTree = [ File "CryPrim.c"+ , File "CryPrim.o"+ , File "cryptol.h"+ ]+ srcTree = unwrap csp +++ [ Directory "Haskell*cryptol\\Haskell" (unwrap hs)+ , Directory "lib*cryptol\\lib" (unwrap libr)+ , Directory "mk*cryptol\\mk" (unwrap mk)+ , File (topDir ++ "\\Makefile")+ , File (topDir ++ "\\README")+ ]+ return $+ Directory "cryptol" + [ File (lFile topDir "CSP\\Cryptol\\cryptol.exe")+ , Directory "data*cryptol\\build\\data" [dataTree]+ , Directory "doc" docTree+ , Directory "DSL" dslTree+ , Directory "examples*cryptol\\build" [ex]+ , Directory "include*cryptol\\CSP\\Cryptol\\include" incTree+ , Directory "lib*cryptol\\build" [lib]+ , Directory "src*cryptol\\CSP" srcTree+ , Directory "tests*cryptol\\CSP\\Cryptol\\tests" (unwrap tst)+ ]+ where+ unwrap (Directory _ xs) = xs+ + iSuffixes+ = [ "hs", "lhs", "c", "h", "doc", "mk", "tex"]++ topDir = srcDir ++ "\\cryptol"+ ofInterest file = + let+ base = baseName file+ suf = fileSuffix file+ in not (last file `elem` "~#") &&+ not (base == "CVS") &&+ not ( ".#" `isPrefixOf` base) &&+ not ( "." `isPrefixOf` base) &&+ (null suf || suf `elem` iSuffixes)+-}++distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing++-- if provided, a mapping from dist tree filename to the+-- the feature it belongs to. If Nothing, all files are+-- mapped to the base feature.+featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++finalMessage :: Maybe String+finalMessage = Nothing++userInstall :: Bool+userInstall = True++services :: [Service]+services = []++ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Nothing++nestedInstalls = []
+ templates/GHC.hs view
@@ -0,0 +1,165 @@+--+-- (c) 2007, Galois, Inc.+--+-- Template file for (big) GHC installers.+--+-- Assumes that you've already created a 'binary-dist' tree+-- (and re-jigged it) before invoking the installer builder.+--+-- ToDo: +-- - make profiling a separate feature.+-- - bundle up less-used packages into separate installers.+-- +module GHC where++import Util.Dir+import Util.Path+import Bamse.Package+import Bamse.PackageUtils++-- Start section of version-specific settings:+versionNumber = "6.6.1"+versionStringUser = "version " ++ versionNumber+buildNumber = "0"+ghcVersion = "ghc-" ++ versionNumber+-- End section++-- default name of output file; used if no -o option is provided.+defaultOutFile = toMsiFileName ghcVersion++-- +pkg :: Package+pkg = Package+ { name = "GHC-"++versionStringUser+ , title = "Glasgow Haskell Compiler, " ++ versionStringUser+ , productVersion = versionNumber ++ '.':buildNumber+ , author = "Sigbjorn Finne"+ , comment = "GHC " ++ versionStringUser+ }++webSite :: String+webSite = "http://haskell.org/ghc"++bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner.bmp")++bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap ienv = Just (lFile (toolDir ienv) "art/ghc-background.bmp")++registry :: [RegEntry]+registry + = haskellImpl "GHC" ghcVersion+ [ ("InstallDir", "[TARGETDIR]") ]++features :: [Tree Feature]+features = [ Leaf baseFeature ]++baseFeatureName :: String+baseFeatureName = "GHC"++baseFeature :: (String, String)+baseFeature = (baseFeatureName, "Glasgow Haskell Compiler")++startMenu :: InstallEnv -> (String, [Shortcut])+startMenu ienv = ("GHC/" ++ versionNumber, entries)+ where+ entries :: [Shortcut]+ entries = + [ Shortcut "GHCi"+ (lFile (srcDir ienv) "bin\\ghci.exe")+ ""+ "GHC interpreter"+ (Just (lFile iconDir "hsx2.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "GHC Readme"+ (lFile (srcDir ienv) "README.txt")+ ""+ "GHC Readme"+ (Just (lFile iconDir "txt.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "GHC documentation"+ (lFile (srcDir ienv) "doc\\html\\index.html")+ ""+ "GHC documentation"+ (Just (lFile iconDir "html.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "GHC library documentation"+ (lFile (srcDir ienv) "doc\\html\\libraries\\index.html")+ ""+ "GHC lib doc"+ (Just (lFile iconDir "html.exe"))+ 1+ "[TARGETDIR]"+ ]++ iconDir = toolDir ienv ++ "\\icons"++desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts _ienv = []++extensions :: InstallEnv -> [ Extension ]+extensions ienv = + [ hsExt "hs"+ , hsExt "lhs"+ ]+ where+ hsExt = haskellExtension ghci (srcDir ienv) (toolDir ienv)+ ghci = lFile (srcDir ienv) "bin\\ghci.exe"++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = [ ( "lhs"+ , "open"+ , "&Open with GHCi"+ , "\"%1\""+ )+ , ( "hs"+ , "open"+ , "&Open with GHCi"+ , "\"%1\""+ )+ ]++dirTree :: InstallEnv -> IO DirTree+dirTree ienv = findFiles ofInterest (srcDir ienv)+ where+ ofInterest file = not (not (null (tail file)) && last file == '~') &&+ not (baseName file == "CVS")+ +distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing++featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++license :: InstallEnv -> Maybe FilePath+license _ienv = Nothing++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder = Just $ "[WindowsVolume]ghc\\"++ghcVersion+-- Example of how to use an environment variable:+--defaultInstallFolder = Just $ "[%SYSTEMDRIVE]\\ghc\\"++ghcVersion++finalMessage :: Maybe String+finalMessage = Just "Please remember to add [TARGETDIR]bin to your PATH."++userInstall :: Bool+userInstall = True++services :: [Service]+services = []++ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Nothing++nestedInstalls = []
+ templates/GaloisPkg.hs view
@@ -0,0 +1,151 @@+--+-- (c) 2007, Galois, Inc.+--+-- To create a package, you need to define a module+-- which exports information and functions that together+-- define the functionality (and contents) of your package.+--+-- [Having Haskell as the only 'specification language' for packages+-- is not a goal. ]+module GaloisPkg where++import Util.Dir+import Util.Path+import Bamse.Package+import Bamse.PackageUtils+import Debug.Trace+import Data.Maybe ( fromJust )++versionNumber = "0.10"+libName="galois"+libVersion = "galois-" ++ versionNumber++defaultOutFile = toMsiFileName libVersion++pkg :: Package+pkg = Package+ { name = "GaloisPkg"+ , title = "Galois Haskell libraries (for GHC 6.2.2)"+ , productVersion = "1.0.0.0"+ , author = "Galois Connections, Inc"+ , comment = "Version: " ++ versionNumber+ }++webSite :: String+webSite = "http://galois.com/"++bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner.bmp")++bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap _ = Nothing++registry :: [RegEntry]+registry = []++features :: [Tree Feature]+features = [ Leaf baseFeature ]++baseFeatureName :: String+baseFeatureName = "GaloisPkg"++baseFeature :: Feature+baseFeature = (baseFeatureName, "Galois Haskell library for GHC")++startMenu :: InstallEnv -> (String, [Shortcut])+startMenu ienv = ("GHC/ghc-" +++ ghc_forVersion (fromJust ghcPackageInfo) +++ "/libraries/"++libName, entries)+ where+ entries :: [Shortcut]+ entries = + [ Shortcut "Documentation (HTML)"+ (lFile (srcDir ienv) "doc\\index.html")+ ""+ "Library documentation"+ (Just (lFile iconDir "html.exe"))+ 1+ "[TARGETDIR]"+ ]++ iconDir = toolDir ienv ++ "\\icons"++desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts ienv = []++extensions :: InstallEnv -> [ Extension ]+extensions ienv = [ ]++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = []++dirTree :: InstallEnv -> IO DirTree+dirTree ienv = findFiles ofInterest (srcDir ienv)+ where+ -- Note: 'path' is prefixed by 'topDir'.+ ofInterest path = True+{-+ = path == topDir + || baseName path `elem` ["com.pkg", "HScom.o", "doc", "imports", "include"]+ || baseName path == "doc" || baseName (dirname path) == "doc"+ || fileSuffix path `elem` [{-"",-} "a", "hi", "h"]+ -- By leaving out "", we won't recurse into subdirs. We specially+ -- check for the toplevel directory, as it needs to be present.+-- (fileSuffix file `elem` [""{-directory-}, "dll", "hs", "lhs", "idl", "h", "pkg"])+ +-}++distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing -- Just ( \ f -> Just (toDist f))+ where+ -- Note: 'fn' does not have 'topDir' prepended to it.+ toDist fn+ | isHiFile fn = lFile "imports" fn -- store interface files in the imports/ directory,+ | isDocFile fn = lFile "doc" fn -- doc/html files in doc/ directory, + | isHeaderFile fn = lFile "include" fn -- header files in include/, + | otherwise = baseName fn -- and everything else in the toplevel directory.++featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++license :: InstallEnv -> Maybe FilePath+license ienv = Nothing++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder = Nothing++finalMessage :: Maybe String+finalMessage = Nothing++userInstall :: Bool+userInstall = False++services :: [Service]+services = []++ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Just $+ GhcPackage { ghc_packageName = "galois"+ -- ToDo: allow 'most-recent' compiler to be used.+ , ghc_forVersion = "6.2.2"+ , ghc_packageFile = Just "galois.pkg"+ , ghc_pkgCmdLine = Just (unwords [ def "impdir" "imports"+ , def "libdir" ""+ ])+ }+ where+ tgt "" = "\"[TARGETDIR]\\\""+ tgt s = "\"[TARGETDIR]\\\\" ++ s ++ "\""+ + def s v = '-':'D':s ++ '=':tgt v++nestedInstalls = []+
+ templates/Greencard.hs view
@@ -0,0 +1,131 @@+--+-- (c) 2007, Galois, Inc.+--+-- To create a package, you need to define a module+-- which exports information and functions that together+-- define the functionality (and contents) of your package.+--+-- [Having Haskell as the only 'specification language' for packages+-- is not a goal. ]+module Greencard where++import Util.Dir+import Util.Path+import Bamse.Package+import Bamse.PackageUtils++gcVersion = "gc-2.05"+versionNumber = "2.05"++defaultOutFile = toMsiFileName gcVersion++pkg :: Package+pkg = Package+ { name = "GreenCard"+ , title = "GreenCard - Haskell FFI preprocessor"+ , productVersion = "1.0.0.0"+ , author = "Sigbjorn Finne"+ , comment = "Version: " ++ versionNumber+ }++webSite :: String+webSite = "http://haskell.org/greencard"++bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner.bmp")++bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap _ienv = Nothing++registry :: [RegEntry]+registry = haskellProject "GreenCard" + [ hugsPath "[TARGETDIR]\\lib\\hugs" ]++features :: [Tree Feature]+features = [ Leaf baseFeature ]++baseFeatureName :: String+baseFeatureName = "GreenCard"++baseFeature :: Feature+baseFeature = (baseFeatureName, "GreenCard")++startMenu :: InstallEnv -> (String, [Shortcut])+startMenu ienv = ("GreenCard", entries)+ where+ entries :: [Shortcut]+ entries = + [ Shortcut "GreenCard Readme"+ (lFile (srcDir ienv) "README.txt")+ ""+ "GHC Readme"+ (Just (lFile iconDir "txt.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "User guide"+ (lFile (srcDir ienv) "doc\\green-card\\greencard.html")+ ""+ "User guide"+ (Just (lFile iconDir "html.exe"))+ 1+ "[TARGETDIR]"+ ]++ iconDir = toolDir ienv ++ "\\icons"++desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts _ienv = []++extensions :: InstallEnv -> [ Extension ]+extensions _ienv = [ ]++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = [ ]++dirTree :: InstallEnv -> IO DirTree+dirTree ienv = findFiles ofInterest (srcDir ienv)+ where+ ofInterest file = not (last file == '~') &&+ not (baseName file == gcVersion) &&+ not (baseName file == "green-card.junk") &&+ not (baseName file == "distrib") &&+ not (baseName file == "CVS") &&+ not (baseName file == "mk") &&+ (not (fileSuffix file == "o") ||+ (baseName file == "HSgreencard.o")) &&+ (not (fileSuffix file == "hi") ||+ (baseName file == "StdDIS.hi"))+ +distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing++featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++license :: InstallEnv -> Maybe FilePath+license _ienv = Nothing++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder = Nothing++finalMessage :: Maybe String+finalMessage = Just "Please remember to add [TARGETDIR] to your PATH."++userInstall :: Bool+userInstall = False++services :: [Service]+services = []++ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Nothing++nestedInstalls = []
+ templates/HDirectLib.hs view
@@ -0,0 +1,107 @@+--+-- (c) 2007, Galois, Inc.+--+-- To create a package, you need to define a module+-- which exports information and functions that together+-- define the functionality (and contents) of your package.+--+-- [Having Haskell as the only 'specification language' for packages+-- is not a goal. ]+--+-- Installer definition for the HaskellDirect Hugs libraries.+-- +module HDirectLib where++import Util.Dir+import Util.Path+import Bamse.Package+import Bamse.PackageUtils++libVersion = "hdirect-lib-0.19-hugsDec2001"+versionNumber = "0.19"++defaultOutFile = toMsiFileName libVersion++pkg :: Package+pkg = Package+ { name = "HDirectLib"+ , title = "HDirect COM library for Hugs"+ , productVersion = "1.0.0.0"+ , author = "Sigbjorn Finne"+ , comment = "Version: " ++ versionNumber+ }++webSite :: String+webSite = "http://haskell.org/hdirect"++bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner.bmp")++bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap _ienv = Nothing++registry :: [RegEntry]+registry = haskellProject "HDirect" + [ hugsPath "[TARGETDIR]" ]++features :: [Tree Feature]+features = [ Leaf baseFeature ]++baseFeatureName :: String+baseFeatureName = "HDirect"++baseFeature :: Feature+baseFeature = (baseFeatureName, "HaskellDirect")++startMenu :: InstallEnv -> (String, [Shortcut])+startMenu _ienv = ("HDirect", []) -- i.e., no menu entry++desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts _ienv = []++extensions :: InstallEnv -> [ Extension ]+extensions _ienv = [ ]++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = []++dirTree :: InstallEnv -> IO DirTree+dirTree ienv = findFiles ofInterest (srcDir ienv)+ where+ -- Note: the file is also the name of the directory+ ofInterest file = + (fileSuffix file `elem` [""{-directory-}, "dll", "hs", "lhs", "idl", "h"])+ +distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing++featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++license :: InstallEnv -> Maybe FilePath+license _ienv = Nothing++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder = Nothing -- Just "c:\\ghc\\ghc-5.04"++finalMessage :: Maybe String+finalMessage = Nothing++userInstall :: Bool+userInstall = False++services :: [Service]+services = []++ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Nothing++nestedInstalls = []
+ templates/Haddock.hs view
@@ -0,0 +1,129 @@+--+-- (c) 2007, Galois, Inc.+--+-- To create a package, you need to define a module+-- which exports information and functions that together+-- define the functionality (and contents) of your package.+--+-- [Having Haskell as the only 'specification language' for packages+-- is not a goal. ]+module Haddock where++import Data.List++import Util.Dir+import Util.Path+import Util.List+import Bamse.Package+import Bamse.PackageUtils++pkgName = "haddock"+pkgVersion = "0.7"+pkgDoc = "doc\\haddock\\haddock.html"++defaultOutFile = toMsiFileName pkgName++pkg :: Package+pkg = Package+ { name = pkgName+ , title = pkgName+ , productVersion = "0.7"+ , author = "Simon Marlow"+ , comment = unwords [pkgName, "Version", pkgVersion]+ }++webSite :: String+webSite = "http://haskell.org/haddock"++bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner.bmp")++bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap _ienv = Nothing++{-+ The installer needs to record the following in the Registry:+ * the location of the installation directory.+ -- used by the Cryptol interpreter to set up the Cryptol+ import path when invoking GHC.+ * Cryptol as a Hugs 'project' -- requires the addition of+ a (large) set of directories to the search path.+-}+registry :: [RegEntry]+registry + = []++features :: [Tree Feature]+features = [ Leaf baseFeature ]++baseFeatureName :: String+baseFeatureName = pkgName++baseFeature :: Feature+baseFeature = (baseFeatureName, pkgName ++ '-':pkgVersion)++startMenu :: InstallEnv -> (String, [Shortcut])+startMenu ienv = (pkgName, entries)+ where+ iconDir = lFile (toolDir ienv) "icons"++ entries :: [Shortcut]+ entries = + [ Shortcut "Haddock user manual"+ (lFile (srcDir ienv) pkgDoc)+ ""+ "Haddock documentation"+ (Just (lFile iconDir "html.exe"))+ 1+ "[TARGETDIR]"+ ]++desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts _ienv = []++extensions :: InstallEnv -> [ Extension ]+extensions _ienv = []++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = [ ]++dirTree :: InstallEnv -> IO DirTree+dirTree ienv = findFiles ofInterest (srcDir ienv)+ where+ ofInterest file = not (last file == '~') &&+ not (baseName file == "CVS")+ +distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing++featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++license :: InstallEnv -> Maybe FilePath+license _ienv = Nothing++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder + = Just $ "[WindowsVolume]"++pkgName++'\\':pkgName++'-':pkgVersion++finalMessage :: Maybe String+finalMessage = Nothing++userInstall :: Bool+userInstall = False++services :: [Service]+services = []++ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Nothing++nestedInstalls = []
+ templates/Happy.hs view
@@ -0,0 +1,129 @@+--+-- (c) 2007, Galois, Inc.+--+-- To create a package, you need to define a module+-- which exports information and functions that together+-- define the functionality (and contents) of your package.+--+-- [Having Haskell as the only 'specification language' for packages+-- is not a goal. ]+module Happy where++import Data.List++import Util.Dir+import Util.Path+import Util.List+import Bamse.Package+import Bamse.PackageUtils++pkgName = "happy"+pkgVersion = "1.15"+pkgDoc = "doc\\happy\\index.html"++defaultOutFile = toMsiFileName pkgName++pkg :: Package+pkg = Package+ { name = pkgName+ , title = pkgName+ , productVersion = "1.1.5.0"+ , author = "Simon Marlow"+ , comment = unwords [pkgName, "Version", pkgVersion]+ }++webSite :: String+webSite = "http://haskell.org/happy"++bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner.bmp")++bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap _ienv = Nothing++{-+ The installer needs to record the following in the Registry:+ * the location of the installation directory.+ -- used by the Cryptol interpreter to set up the Cryptol+ import path when invoking GHC.+ * Cryptol as a Hugs 'project' -- requires the addition of+ a (large) set of directories to the search path.+-}+registry :: [RegEntry]+registry + = []++features :: [Tree Feature]+features = [ Leaf baseFeature ]++baseFeatureName :: String+baseFeatureName = pkgName++baseFeature :: Feature+baseFeature = (baseFeatureName, pkgName ++ '-':pkgVersion)++startMenu :: InstallEnv -> (String, [Shortcut])+startMenu ienv = (pkgName, entries)+ where+ iconDir = lFile (toolDir ienv) "icons"++ entries :: [Shortcut]+ entries = + [ Shortcut "Happy user manual"+ (lFile (srcDir ienv) pkgDoc)+ ""+ "Happy documentation"+ (Just (lFile iconDir "html.exe"))+ 1+ "[TARGETDIR]"+ ]++desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts _ienv = []++extensions :: InstallEnv -> [ Extension ]+extensions _ienv = []++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = [ ]++dirTree :: InstallEnv -> IO DirTree+dirTree ienv = findFiles ofInterest (srcDir ienv)+ where+ ofInterest file = not (last file == '~') &&+ not (baseName file == "CVS")+ +distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing++featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++license :: InstallEnv -> Maybe FilePath+license _ienv = Nothing++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder + = Just $ "[WindowsVolume]"++pkgName++'\\':pkgName++'-':pkgVersion++finalMessage :: Maybe String+finalMessage = Nothing++userInstall :: Bool+userInstall = False++services :: [Service]+services = []++ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Nothing++nestedInstalls = []
+ templates/Hugs98.hs view
@@ -0,0 +1,227 @@+--+-- (c) 2007, Galois, Inc.+--+-- To create a package, you need to define a module+-- which exports information and functions that together+-- define the functionality (and contents) of your package.+--+-- [Having Haskell as the only 'specification language' for packages+-- is not a goal. ]+module Hugs98 where++import Bamse.Package+import Bamse.PackageUtils+import Util.Dir+import Util.Path++hugsVersion = "Nov 2003"+versionString = "Nov2003"++defaultOutFile = toMsiFileName "hugs98-Nov2003"++pkg :: Package+pkg = Package+ { name = "Hugs98"+ , title = "Hugs98 " ++ versionString+ , productVersion = "1.0.0.0"+ , author = "Sigbjorn Finne"+ , comment = "Hugs98 " ++ versionString+ }++webSite :: String+webSite = "http://haskell.org/hugs"++bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner.bmp")++bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap _ienv = Nothing++registry :: [RegEntry]+registry + = haskellImpl "Hugs" hugsVersion+ [ ("InstallDir", "[TARGETDIR]") ]++features :: [Tree Feature]+features = [ Leaf baseFeature ]++baseFeatureName :: FeatureName+baseFeatureName = "Hugs98"++baseFeature :: Feature+baseFeature = (baseFeatureName, "Hugs98 interpreter")++startMenu :: InstallEnv -> (String, [Shortcut])+startMenu ienv = ("Hugs98/"++versionString, entries)+ where+ entries :: [Shortcut]+ entries = + [ Shortcut "Hugs (Haskell98 mode)"+ (lFile topDir "hugs.exe")+ "+98"+ "Hugs98 interpreter (Haskell98 mode)"+ (Just (lFile iconDir "hsx.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "Hugs (Hugs mode)"+ (lFile topDir "hugs.exe")+ "-98"+ "Hugs98 interpreter (Hugs mode)"+ (Just (lFile iconDir "hsx.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "WinHugs (Haskell98 mode)"+ (lFile topDir "winhugs.exe")+ "+98"+ "WinHugs interpreter (Haskell98 mode)"+ (Just (lFile iconDir "hugs.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "WinHugs (Hugs mode)"+ (lFile topDir "winhugs.exe")+ "-98"+ "Hugs98 interpreter (Hugs mode)"+ (Just (lFile iconDir "hugs.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "Hugs98 Readme"+ (lFile topDir "Readme.txt")+ ""+ "Hugs98 Readme"+ (Just (lFile iconDir "txt.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "Hugs98 documentation (HTML)"+ (lFile topDir "docs\\users_guide\\users-guide.html")+ ""+ "Hugs98 documentation (HTML)"+ (Just (lFile iconDir "html.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "Hugs98 documentation (PDF)"+ (lFile topDir "docs\\users_guide\\users_guide.pdf")+ ""+ "Hugs98 documentation (PDF)"+ (Just (lFile iconDir "pdf.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "Original Hugs98 user manual (PDF)"+ (lFile topDir "docs\\hugs.pdf")+ ""+ "Hugs98 documentation (PDF)"+ (Just (lFile iconDir "pdf.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "Original Hugs98 user manual (HTML)"+ (lFile topDir "docs\\hugsman\\index.html")+ ""+ "Hugs98 documentation (HTML)"+ (Just (lFile iconDir "html.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "Original Hugs98 user manual (HTMLHelp)"+ (lFile topDir "docs\\hugs98.chm")+ ""+ "Hugs98 documentation (HTMLHelp)"+ (Just (lFile iconDir "chm.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "Original Hugs98 user manual (WinHelp)"+ (lFile topDir "docs\\hugs.hlp")+ ""+ "Hugs98 documentation (WinHelp)"+ (Just (lFile iconDir "hlp.exe"))+ 1+ "[TARGETDIR]"+ ]++ topDir = srcDir ienv+ iconDir = lFile (toolDir ienv) "icons"++desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts _ienv = []++extensions :: InstallEnv -> [ Extension ]+extensions ienv = + [ hsExt "hs"+ , hsExt "lhs"+ ]+ where+ hsExt = haskellExtension interp (srcDir ienv) (toolDir ienv)+ interp = lFile (srcDir ienv) "hugs.exe"++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = [ ( "lhs"+ , "open"+ , "&Open"+ , "\"%1\""+ )+ , ( "lhs"+ , "open2"+ , "Open with (Hugs exts mode)"+ , "-98 \"%1\""+ )+ , ( "hs"+ , "open"+ , "&Open"+ , "\"%1\""+ )+ , ( "hs"+ , "open2"+ , "Open with (Hugs exts mode)"+ , "-98 \"%1\""+ )+ ]++dirTree :: InstallEnv -> IO DirTree+dirTree ienv = findFiles ofInterest (srcDir ienv)+ where+ topDir = srcDir ienv++ ofInterest file = not (ignoreDir file) &&+ not (last file == '~') &&+ not (baseName file == "CVS")++ ignoreDir file = file `elem` ignore_dirs++ ignore_dirs = map (\ x -> lFile topDir x) $+ [ "src", "tests"+ , "bugs", "fptools"+ , "libs", "dotnet"+ , "tools", "lib"+ , "docs\\users_guide_src"+ ]+ +distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing++featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++license :: InstallEnv -> Maybe FilePath+license _ = Nothing++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder = Nothing++finalMessage :: Maybe String+finalMessage = Just "Please remember to add [TARGETDIR] to your PATH."++userInstall :: Bool+userInstall = True++services :: [Service]+services = []++ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Nothing++nestedInstalls = []
+ templates/Hugs98Net.hs view
@@ -0,0 +1,147 @@+--+-- (c) 2007, Galois, Inc.+--+-- To create a package, you need to define a module+-- which exports information and functions that together+-- define the functionality (and contents) of your package.+--+-- [Having Haskell as the only 'specification language' for packages+-- is not a goal. ]+module Hugs98Net where++import Bamse.Package+import Bamse.PackageUtils+import Util.Dir+import Util.Path++versionNumber = "March2003"++defaultOutFile = "hugs98-net-March2003.msi"+packageDir = "hugs98-net"+++pkg :: Package+pkg = Package+ { name = "Hugs98.NET"+ , title = "Hugs98 for .NET"+ , productVersion = "1.0.0.0"+ , author = "Sigbjorn Finne"+ , comment = "Hugs98 for .NET " ++ versionNumber+ }++webSite :: String+webSite = "http://galois.com/~sof/hugs98.net/"++bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner.bmp")++bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap _ienv = Nothing++registry :: [RegEntry]+registry + = haskellImpl "Hugs98.Net" "March 2002"+ [ ("InstallDir", "[TARGETDIR]") ]++features :: [Tree Feature]+features = [ Leaf baseFeature ]++baseFeatureName :: FeatureName+baseFeatureName = "Hugs98.NET"++baseFeature :: Feature+baseFeature = (baseFeatureName, "Hugs98.NET")++startMenu :: InstallEnv -> (String, [Shortcut])+startMenu ienv = ("Hugs98.NET", entries)+ where+ topDir = srcDir ienv+ iconDir = lFile (toolDir ienv) "icons"++ entries :: [Shortcut]+ entries = + [ Shortcut "Hugs (Haskell98 mode)"+ (lFile topDir "hugs.exe")+ "+98"+ "Hugs98 interpreter (Haskell98 mode)"+ (Just (lFile iconDir "hsx.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "Hugs (Hugs mode)"+ (lFile topDir "hugs.exe")+ "-98"+ "Hugs98 interpreter (Hugs mode)"+ (Just (lFile iconDir "hsx.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "Hugs98 Readme"+ (lFile topDir "Readme.txt")+ ""+ "Hugs98 Readme"+ (Just (lFile iconDir "txt.exe"))+ 1+ "[TARGETDIR]"+ , Shortcut "Hugs98.Net documentation"+ (lFile topDir "dotnet\\doc\\dotnet.html")+ ""+ "Hugs98.Net documentation"+ (Just (lFile iconDir "html.exe"))+ 1+ "[TARGETDIR]"+ ]++desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts _ienv = []++-- turn off registration of Hugs98.net specific extensions + verbs.+extensions :: InstallEnv -> [ Extension ]+extensions _ienv = [ ]++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = []++dirTree :: InstallEnv -> IO DirTree+dirTree ienv = findFiles ofInterest topDir+ where+ topDir = srcDir ienv ++ ofInterest file = file /= topDir ++ "\\src" &&+ file /= topDir ++ "\\tests" &&+ file /= topDir ++ "\\demos" &&+ file /= topDir ++ "\\tools" &&+ not (last file == '~') &&+ not (baseName file == "CVS")+ +distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing++featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++license :: InstallEnv -> Maybe FilePath+license _ienv = Nothing++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder = Nothing++finalMessage :: Maybe String+finalMessage = Nothing++userInstall :: Bool+userInstall = False++services :: [ Service ]+services = []++ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Nothing++nestedInstalls = []
+ templates/PubCryptol.hs view
@@ -0,0 +1,250 @@+--+-- (c) 2007, Galois, Inc.+--+-- Specification/template for the (public) Cryptol installer builder.+--+-- To create your own installer, you need to supply a Haskell module+-- which exports functions and values that together define the+-- functionality (and contents) of your package;+-- see Base.hs just what those exports are.+--+module PubCryptol where++import Bamse.Package+import Bamse.PackageUtils++import Data.List ( intersperse )+import Util.Dir ( DirTree(..), findFiles )+import Util.Path ( baseName )+import Util.List ( concatWith )++pkgName = "Cryptol"+pkgVersion = "0.1" -- expandString "$<VERSION:1.4.2pre2>"++-- what to output the MSI as if no -o option is given.+defaultOutFile = toMsiFileName (pkgName ++ '-':pkgVersion)++-- 'information summary stream' data bundled up together.+pkg :: Package+pkg = Package+ { name = pkgName+ , title = pkgName ++ ", version " ++ pkgVersion+ , productVersion = "1.0.0.0"+ , author = "Galois Connections, Inc."+ , comment = unwords [pkgName, "Version", pkgVersion]+ }++webSite :: String+webSite = "http://www.cryptol.net/"++bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner3.bmp")++bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap ienv = Just (lFile (toolDir ienv) "art/bground2.bmp")++{-+ The installer needs to record the following in the Registry:+ * the location of the installation directory.+ -- used by the Cryptol interpreter to set up the Cryptol+ import path when invoking GHC.+ * Cryptol as a Hugs 'project' -- requires the addition of+ a (large) set of directories to the search path.+-}+registry :: [RegEntry]+registry + = cryptolSettings +++ haskellProject "Cryptol"+ [ ("hugsPath", (sepBy ';' [ tgt "src\\lib\\hugs"+ , tgt "src\\lib\\parsec"+ , tgt "src\\CSP\\lib"+ , tgt "src\\CSP\\lib\\hugs"+ , tgt "src\\lib\\misc"+ , tgt "src\\CSP\\Cryptol"+ ]))+ ] +++ -- ToDo: verify that this isn't required with Dec'01 of Hugs.+ -- (i.e., Hugs has had an upper limit on the length of 'hugsPath'.)+ haskellProject "CryptolExtras"+ [ ("hugsPath", (sepBy ';' [ tgt "src\\CSP\\Cryptol\\win32"+ , tgt "src\\lib\\misc\\win32"+ ]))+ ]+ where+ sepBy ch ls = concatWith ch ls+ tgt = ("[TARGETDIR]"++)++cryptolSettings = + -- ToDo: have the interpreter create these entries on-the-fly, if missing.+ -- => drop these entries.+ [ RegEntry "HKCU" "Software" (CreateKey False)+ , RegEntry "HKCU" "Software\\Cryptol" (CreateKey True)+ , RegEntry "HKCU" "Software\\Cryptol" (CreateName (Just "Options") "")+ ]+++baseFeatureName :: String+baseFeatureName = pkgName++baseFeature :: Feature+baseFeature = (baseFeatureName, pkgName ++ '-':pkgVersion)++features :: [Tree Feature]+features = [ Leaf baseFeature ]+{-+ , Leaf ("Test", "The test feature")+ , Node ("ParentTest", "A parent test feature")+ [ Leaf ("Child1", "A child feature")+ , Leaf ("Child2", "Another child feature")+ ]+ ]+-}++startMenu :: InstallEnv -> (String, [Shortcut])+startMenu ienv = (pkgName, shortcuts ienv)++shortcuts :: InstallEnv -> [Shortcut]+shortcuts ienv = + [ Shortcut "Cryptol interpreter"+ (lFile (srcDir ienv) "cryptol.exe")+ ""+ "Cryptol interpreter"+ (Just (lFile iconDir "cry.exe"))+ 1+ "[TARGETDIR]"+ ]+ where+ iconDir = lFile (toolDir ienv) "icons"++desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts ienv = shortcuts ienv++extensions :: InstallEnv -> [ Extension ]+extensions ienv+ = [ cryptolExtension (srcDir ienv) (toolDir ienv) "cry"+ ]++cryptolExtension :: FilePath -> FilePath -> String -> Extension+cryptolExtension topDir toolDir ext + = ( "CryptolFile"+ , lFile topDir "cryptol.exe"+ , lFile iconDir "cry.exe"+ , ext+ )+ where+ iconDir = lFile toolDir "icons"++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = [ ( "cry"+ , "open"+ , "&Open"+ , "\"%1\""+ )+ ]++license :: InstallEnv -> Maybe FilePath+license _ienv = Nothing++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder = Nothing++dirTree :: InstallEnv -> IO DirTree+dirTree ienv = findFiles ofInterest (srcDir ienv)+ where+ ofInterest file = not (last file == '~') &&+ not (baseName file == "CVS") &&+ not (baseName file == "bin")+ +{- Older experiment in specifying a dist tree which differed+ from the source tree. Keep around as it might prove useful+ later on.+dirTree :: FilePath -> IO DirTree+dirTree = do + aes <- findFilesRel ofInterest (topDir ++ "\\build\\share\\galois\\AES")+ ex <- findFilesRel ofInterest (topDir ++ "\\build\\Examples")+ lib <- findFilesRel ofInterest (topDir ++ "\\build\\lib")+ csp <- findFilesRel ofInterest (topDir ++ "\\CSP")+ hs <- findFilesRel ofInterest (topDir ++ "\\Haskell")+ libr <- findFilesRel ofInterest (topDir ++ "\\lib")+ mk <- findFilesRel ofInterest (topDir ++ "\\mk")+ tst <- findFilesRel ofInterest (topDir ++ "\\CSP\\Cryptol\\tests")+ let+ dataTree = aes+ docTree = [ File (topDir ++ "\\CSP\\Documentation\\CheatSheet.doc")+ , File (topDir ++ "\\CryptolIntro.ps")+ , File (topDir ++ "\\CryptolIntro.tex")+ ]+ dslTree = [ File (topDir ++ "\\DSL\\Perms.hs")+ , File (topDir ++ "\\DSL\\Permute.hs")+ ]+ incTree = [ File "CryPrim.c"+ , File "CryPrim.o"+ , File "cryptol.h"+ ]+ srcTree = unwrap csp +++ [ Directory "Haskell*cryptol\\Haskell" (unwrap hs)+ , Directory "lib*cryptol\\lib" (unwrap libr)+ , Directory "mk*cryptol\\mk" (unwrap mk)+ , File (topDir ++ "\\Makefile")+ , File (topDir ++ "\\README")+ ]+ return $+ Directory "cryptol" + [ File (lFile topDir "CSP\\Cryptol\\cryptol.exe")+ , Directory "data*cryptol\\build\\data" [dataTree]+ , Directory "doc" docTree+ , Directory "DSL" dslTree+ , Directory "examples*cryptol\\build" [ex]+ , Directory "include*cryptol\\CSP\\Cryptol\\include" incTree+ , Directory "lib*cryptol\\build" [lib]+ , Directory "src*cryptol\\CSP" srcTree+ , Directory "tests*cryptol\\CSP\\Cryptol\\tests" (unwrap tst)+ ]+ where+ unwrap (Directory _ xs) = xs+ + iSuffixes+ = [ "hs", "lhs", "c", "h", "doc", "mk", "tex"]++ topDir = srcDir ++ "\\cryptol"+ ofInterest file = + let+ base = baseName file+ suf = fileSuffix file+ in not (last file `elem` "~#") &&+ not (base == "CVS") &&+ not ( ".#" `isPrefixOf` base) &&+ not ( "." `isPrefixOf` base) &&+ (null suf || suf `elem` iSuffixes)+-}++distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing++-- if provided, a mapping from dist tree filename to the+-- the feature it belongs to. If Nothing, all files are+-- mapped to the base feature.+featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++finalMessage :: Maybe String+finalMessage = Nothing++userInstall :: Bool+userInstall = True++services :: [Service]+services = []++ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Nothing++nestedInstalls = []
+ templates/SOE.hs view
@@ -0,0 +1,108 @@+--+-- (c) 2007, Galois, Inc.+--+-- To create a package, you need to define a module+-- which exports information and functions that together+-- define the functionality (and contents) of your package.+--+-- [Having Haskell as the only 'specification language' for packages+-- is not a goal. ]+module SOE where++import MSIExtra+import Util.Dir+import Package++defaultOutFile = "SOE.msi"+srcDir = "c:\\src"++pkg :: Package+pkg = Package+ { name = "SOE"+ , title = "School of Expression Software"+ , productVersion = "1.0.0.0"+ , author = "Paul Hudak"+ , comment = "Software accompanying textbook"+ , date = pkg_date+ , revisionGUID = "{07a7cf12-5509-45d3-92d3-826b95dde09f}"+ , packageGUID = "{79a39c17-1723-437f-a415-b7ca566fa96b}"+ , creationTime = pkg_date+ }+ where+ pkg_date = "13/01/2002 23:00:00"++webSite :: String+webSite = "http://haskell.org/soe"++bannerBitmap :: Maybe FilePath+bannerBitmap = Just "c:/src/bamse/soe/banner.bmp"++registry :: [RegEntry]+registry + = haskellProject "SOE"+ [ hugsPath "[TARGETDIR]src;[TARGETDIR]graphics\\lib\\win32;[TARGETDIR]haskore\\src" ]+++hugsPath val = ("hugsPath", val)++haskellProject nm values+ = RegEntry "HKLM" "Software" (CreateKey False) :+ RegEntry "HKLM" "Software\\Haskell" (CreateKey False) :+ RegEntry "HKLM" "Software\\Haskell\\Projects" (CreateKey False) :+ RegEntry "HKLM" proj_path (CreateKey True) :+ map (\ (nm,val) -> RegEntry "HKLM" proj_path+ (CreateName (Just nm) val))+ values+ where+ proj_path = "Software\\Haskell\\Projects\\"++nm++features :: [(String, String)]+features = [ baseFeature ]++baseFeature :: (String, String)+baseFeature = ("SOE", "School of Expression")++startMenu :: (String, [Shortcut])+startMenu = ("School of Expression", entries)+ where+ entries :: [Shortcut]+ entries = + [ Shortcut "Source code"+ "c:\\src\\soelib\\src\\Code.html"+ ""+ "Example code"+ (Just ("c:\\src\\bamse\\soe\\html.exe"))+ 1+ "[TARGETDIR]src"+ ]++desktopShortcuts :: [Shortcut]+desktopShortcuts = []++extensions :: [ Extension ]+extensions = []++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = []++dirTrees :: IO [DirTree]+dirTrees = do + fs <- findFiles ofInterest (srcDir ++ "\\soelib")+ return [fs]+ where+ ofInterest file = not (last file == '~')+ +license :: Maybe FilePath+license = Nothing -- Just "c:\\src\\soelib\\license.rtf"++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder = Nothing+
+ tools/Makefile view
@@ -0,0 +1,11 @@+#+# Makefile for building 'msiIcon', a util for extracting+# icons for use with MSI file types.+#+CC=cl+LIBS=shell32.lib++all : msiIcon.exe++msiIcon.exe : msiIcon.c+ $(CC) $(CC_OPTS) -o $@ $< $(LIBS)
+ tools/README.txt view
@@ -0,0 +1,10 @@+This directory contains a simple utility for packaging up icons+in the way expected by the MSI table, Icon, i.e., as an .exe+containing one icon resource.++The utility lets you select an icon from a .dll/.exe/.ico, which+it then proceeds to bake into an empty .exe++To build&use the util, you'll need to have a copy of MSVC++ installed.++sof 2/02
+ tools/msiIcon.c view
@@ -0,0 +1,252 @@+/*+ * Utility for selecting and extracting an icon resource from a .DLL/.EXE/.ICO+ *+ * Usage: msiIcon <name>+ *+ * creates <name>.exe containing your icon of choice as a resource. Apart from+ * the icon resource data, the .exe contains just a trivial entry point.+ *+ * sof 2/02+ */+#include <windows.h>+#include <stdio.h>+#include "msiIcon.h"++typedef BOOL (WINAPI *PickIconDlgTy)(HWND,LPWSTR,DWORD,LPDWORD);+static BOOL WriteIcon(LPWSTR fName, LPWSTR dllName, DWORD idx);++int+main(int argc, char* argv[])+{+ HINSTANCE hShell;+ PickIconDlgTy pickIconDlg;+ DWORD iconIdx;+ WCHAR iconHome[MAX_PATH+1];+ char cmd[MAX_PATH+1];+ DWORD maxFileLen = MAX_PATH;+ BOOL hitOk = FALSE;+ FILE* fp;+ int rc = 0;+ + if ( argc != 2) {+ fprintf(stderr, "usage: %s <filepath>\n", argv[0]);+ fprintf(stderr, " e.g., %s myIcons/htmlFile\n", argv[0]);+ return 1;+ }++ /* The icon picker isn't exposed via a documented API,+ * so look it up (@ ordinal 62 of shell32.dll).+ */+ hShell = LoadLibrary("shell32.dll");+ if ( hShell == (HINSTANCE)NULL ) {+ fprintf(stderr, "unable to load shell32.dll\n");+ return 1;+ }+ pickIconDlg = (PickIconDlgTy)GetProcAddress(hShell,(LPCSTR)LOWORD(62));++ if ( (FARPROC)pickIconDlg == NULL ) {+ fprintf(stderr, "couldn't locate PickIconDlg in shell32.dll\n");+ return 1;+ }++ /* Invoke the dialog, passing it initially shell32.dll + ToDo: start with user-specified DLL/EXE instead . */+ + wcscpy(iconHome,L"shell32.dll");+ hitOk = pickIconDlg(NULL,iconHome, maxFileLen,&iconIdx);++ if (hitOk) {+ /* Looks as if the user meant business - go ahead and extract the icon. */+ if (WriteIcon(L"iconPrep__.ico", iconHome, iconIdx)) {+ if ( (fp = fopen("iconPrep__.rc", "w+")) == NULL) {+ fprintf(stderr, "unable to open '%s'\n", "iconPrep__.rc"); + rc = 1; goto cleanup;+ }+ fprintf(fp,"0 ICON \"iconPrep__.ico\"\n");+ fclose(fp);+ if ( (fp = fopen("iconPrep__.c", "w+")) == NULL) {+ fprintf(stderr, "unable to open '%s'\n", "iconPrep__.c"); + rc = 1; goto cleanup;+ }+ fprintf(fp,"#include <windows.h>\n");+ fprintf(fp,"BOOL APIENTRY DllMain(HANDLE hDLL, DWORD dwReason, LPVOID lpReserved) { return TRUE; }");+ fclose(fp);+ +#if 0 +// If you've got MSVC tools+ system("rc iconPrep__.rc");+ sprintf(cmd, "cl /nologo -o %s.exe iconPrep__.c iconPrep__.res /link /entry:DllMain /subsystem:windows /opt:nowin98",argv[1]);+ system(cmd);+#else+ system("windres -i iconPrep__.rc -o iconPrep__.res -O coff");+ system("gcc -c iconPrep__.c");+ sprintf(cmd, "ld -o %s.exe iconPrep__.o iconPrep__.res -e _DllMain",argv[1]);+ system(cmd);+#endif++ printf("Successfully created MSI icon file %s.exe\n", argv[1]);+// system("del /Q iconPrep__.*");+ }+ }+ +cleanup:+ CloseHandle(hShell);+ return rc;+}+BOOL+WriteIconHeader (HANDLE hFile, WORD sz) {+ DWORD dwW;+ WORD header[3];+ DWORD len = 3*sizeof(WORD);+ + header[0] = 0; // an icon+ header[1] = 1; // reserved+ header[2] = sz;+ + return (WriteFile(hFile, header, len, &dwW, NULL) &&+ dwW == len);+}++/* (Junk) struct used to pass info from the enumerator to the enumerating+ * procedure. + */+typedef struct {+ HMODULE hLib;+ DWORD idx;+ LPTSTR groupIdx;+ DWORD currentIdx;+} Stuff;++BOOL CALLBACK EnumProc( HANDLE hModule,+ LPCTSTR lpszType,+ LPTSTR lpszName,+ LPARAM lParam )+{+ Stuff* state = (Stuff*)lParam;++ if ( state->currentIdx++ == state->idx ) {+ if (HIWORD(lpszName)) {+ /* Gotcha #521: copy that string!! */+ state->groupIdx = strdup(lpszName);+ } else {+ state->groupIdx = lpszName;+ }+ return FALSE;+ } else {+ return TRUE;+ }+}++BOOL+WriteIcon(LPWSTR fName,+ LPWSTR dllName,+ DWORD idx+ )+{+ HANDLE hFile;+ HMODULE hLib;+ HANDLE hRsrc;+ HANDLE hGlobal;+ DWORD dwBytesWritten;+ ICONDIRENTRY id;+ GRPICONDIR* lpGrpIconDir;+ ICONIMAGE* lpIconImage;+ Stuff stuff;+ int nId, i;+ DWORD dwSize, dwNumBytes;+ BOOL rc = TRUE;++ /*+ * The index coming back from the PickIconDlg() is the index of+ * the icon group directory -- that is, its position in the + * list of RT_GROUP_ICONs, not its value/name. Had me stumped+ * for a while, that.+ */+ + if ( (hLib = LoadLibraryExW (dllName, NULL, LOAD_LIBRARY_AS_DATAFILE)) == NULL) {+ if (ExtractIconW(GetModuleHandle(NULL), dllName, -1) == (HICON)1) {+ // It's an .ico file; copy it.+ return CopyFileW(dllName, fName, FALSE);+ }+ fwprintf(stderr, L"WriteIcon: Couldn't load '%s'\n", dllName);+ return FALSE;+ }++ stuff.hLib = hLib;+ stuff.idx = idx;+ stuff.currentIdx = 0;+ + EnumResourceNames (hLib, RT_GROUP_ICON, EnumProc, (LPARAM)&stuff);+ + if ( (hRsrc = FindResource( hLib, stuff.groupIdx, RT_GROUP_ICON)) == NULL ) {+ fprintf(stderr, "WriteIcon: Couldn't locate resource '%s'\n", stuff.groupIdx);+ return FALSE;+ }+ if ( (hGlobal = LoadResource (hLib, hRsrc)) == NULL) {+ fprintf(stderr, "WriteIcon: Couldn't load resource '%s'\n", stuff.groupIdx);+ return FALSE;+ }+ if ( (lpGrpIconDir = LockResource ( hGlobal )) == NULL) {+ fprintf(stderr, "WriteIcon: Couldn't lock resource '%s'\n", stuff.groupIdx);+ return FALSE;+ }+ + if ( (hFile = CreateFileW(fName, GENERIC_WRITE, 0, NULL,+ CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL,+ NULL)) == INVALID_HANDLE_VALUE ) {+ fprintf(stderr, "WriteIcon: Unable to open '%S' for writing\n", fName);+ return FALSE;+ }+ + /* Emit ICON header */+ if ( !WriteIconHeader(hFile,lpGrpIconDir->idCount) ) {+ fprintf(stderr, "WriteIcon: Unable to write header to '%S'\n", fName);+ rc = FALSE ; goto cleanup;+ }+ + dwSize = 3 * sizeof(WORD) + lpGrpIconDir->idCount * sizeof(ICONDIRENTRY);+ dwNumBytes = 0;+ + /* Write out the ICONDIRENTRYs */+ for (i=0; i < lpGrpIconDir->idCount ; i++) {+ id.bWidth = lpGrpIconDir->idEntries[i].bWidth;+ id.bHeight = lpGrpIconDir->idEntries[i].bHeight;+ id.bColorCount = lpGrpIconDir->idEntries[i].bColorCount;+ id.bReserved = lpGrpIconDir->idEntries[i].bReserved;+ id.wPlanes = lpGrpIconDir->idEntries[i].wPlanes;+ id.wBitCount = lpGrpIconDir->idEntries[i].wBitCount;+ id.dwBytesInRes = lpGrpIconDir->idEntries[i].dwBytesInRes;+ dwSize += dwNumBytes;+ id.dwImageOffset = dwSize;+ dwNumBytes = id.dwBytesInRes;++ if( !WriteFile(hFile,+ &id,+ sizeof(ICONDIRENTRY),+ &dwBytesWritten,+ NULL) || dwBytesWritten != sizeof(ICONDIRENTRY) ) {+ rc = FALSE; goto cleanup;+ }+ }++ /* ..followed by the icon data. */+ for (i=0; i < lpGrpIconDir->idCount ; i++) {+ hRsrc = FindResourceEx ( hLib, RT_ICON, MAKEINTRESOURCE(lpGrpIconDir->idEntries[i].nID),+ MAKELANGID(LANG_NEUTRAL, SUBLANG_NEUTRAL));+ hGlobal = LoadResource ( hLib, hRsrc);+ lpIconImage = LockResource( hGlobal );++ if ( !WriteFile( hFile,+ lpIconImage,+ SizeofResource(hLib, hRsrc),+ &dwBytesWritten,+ NULL) || dwBytesWritten != SizeofResource(hLib, hRsrc) ) {+ rc = FALSE; goto cleanup;+ }+ }+ FreeLibrary(hLib);+ +cleanup:+ CloseHandle(hFile);+ return rc;+}
+ tools/msiIcon.h view
@@ -0,0 +1,61 @@+//+// The following structs were copied out of the MSDN article+// "Icons in Win32".+// +typedef struct { + BYTE bWidth; // Width of the image+ BYTE bHeight; // Height of the image (times 2)+ BYTE bColorCount; // Number of colors in image (0 if >=8bpp)+ BYTE bReserved; // Reserved+ WORD wPlanes; // Color Planes+ WORD wBitCount; // Bits per pixel+ DWORD dwBytesInRes; // how many bytes in this resource?+ DWORD dwImageOffset; // where in the file is this image+} ICONDIRENTRY, *LPICONDIRENTRY;++typedef struct {+ WORD idReserved; // Reserved+ WORD idType; // resource type (1 for icons)+ WORD idCount; // how many images?+ ICONDIRENTRY idEntries[1]; // the entries for each image+} ICONDIR, *LPICONDIR; ++typedef struct {+ BITMAPINFOHEADER icHeader; // DIB header+ RGBQUAD icColors[1]; // Color table+ BYTE icXOR[1]; // DIB bits for XOR mask+ BYTE icAND[1]; // DIB bits for AND mask+} ICONIMAGE;++#ifdef _MSC_VER+#pragma pack(push)+#pragma pack(2)+#endif+typedef + struct {+ BYTE bWidth; // width, in pixels, of the image+ BYTE bHeight; // height, in pixels, of the image+ BYTE bColorCount; // Number of colors in image (0 if >= 8bpp)+ BYTE bReserved;+ WORD wPlanes; // color planes+ WORD wBitCount; // bits per pixel+ DWORD dwBytesInRes;+ WORD nID;+} GRPICONDIRENTRY;+#ifdef _MSC_VER+#pragma pack(pop)++#pragma pack(push)+#pragma pack(2)+#endif+typedef + struct {+ WORD idReserved; // Reserved (must be 0).+ WORD idType; // Resource (must be 1 for icons)+ WORD idCount; // How many images?+ GRPICONDIRENTRY idEntries[1]; +} GRPICONDIR;+#ifdef _MSC_VER+#pragma pack(pop)+#endif+