diff --git a/Bamse/Builder.hs b/Bamse/Builder.hs new file mode 100644 --- /dev/null +++ b/Bamse/Builder.hs @@ -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 diff --git a/Bamse/DiaWriter.hs b/Bamse/DiaWriter.hs new file mode 100644 --- /dev/null +++ b/Bamse/DiaWriter.hs @@ -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 diff --git a/Bamse/Dialog.hs b/Bamse/Dialog.hs new file mode 100644 --- /dev/null +++ b/Bamse/Dialog.hs @@ -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 + diff --git a/Bamse/DialogUtils.hs b/Bamse/DialogUtils.hs new file mode 100644 --- /dev/null +++ b/Bamse/DialogUtils.hs @@ -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") + ] +-} + diff --git a/Bamse/GhcPackage.hs b/Bamse/GhcPackage.hs new file mode 100644 --- /dev/null +++ b/Bamse/GhcPackage.hs @@ -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 + } diff --git a/Bamse/IMonad.hs b/Bamse/IMonad.hs new file mode 100644 --- /dev/null +++ b/Bamse/IMonad.hs @@ -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) + diff --git a/Bamse/MSIExtra.hs b/Bamse/MSIExtra.hs new file mode 100644 --- /dev/null +++ b/Bamse/MSIExtra.hs @@ -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 + } diff --git a/Bamse/MSITable.hs b/Bamse/MSITable.hs new file mode 100644 --- /dev/null +++ b/Bamse/MSITable.hs @@ -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 + diff --git a/Bamse/Options.hs b/Bamse/Options.hs new file mode 100644 --- /dev/null +++ b/Bamse/Options.hs @@ -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 = "" + +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}) "") + "Output installer to " + , Option [] ["product-guid"] + (ReqArg (\ s op -> op{opt_productGUID=Just (toGUID s)}) "") + "Use as ProductCode. Required arg without -u" + , Option [] ["revision-guid"] + (ReqArg (\ s op -> op{opt_revisionGUID=Just (toGUID s)}) "") + "Use as RevisionCode. Required arg without -u" + , Option [] ["src-dir"] + (ReqArg (\ s op -> op{opt_srcDir=Just s}) "") + "Use 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}) "") + "Use as the top of the installer tool's own directory tree." + , Option [] ["data-dir"] + (ReqArg (\ s op -> op{opt_dataDir=Just s}) "") + "Use 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 $ 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 + diff --git a/Bamse/Package.hs b/Bamse/Package.hs new file mode 100644 --- /dev/null +++ b/Bamse/Package.hs @@ -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] + diff --git a/Bamse/PackageGen.hs b/Bamse/PackageGen.hs new file mode 100644 --- /dev/null +++ b/Bamse/PackageGen.hs @@ -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 + ] diff --git a/Bamse/PackageUtils.hs b/Bamse/PackageUtils.hs new file mode 100644 --- /dev/null +++ b/Bamse/PackageUtils.hs @@ -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 $) +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" + diff --git a/Bamse/WindowsInstaller.hs b/Bamse/WindowsInstaller.hs new file mode 100644 --- /dev/null +++ b/Bamse/WindowsInstaller.hs @@ -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 " + + diff --git a/Bamse/Writer.hs b/Bamse/Writer.hs new file mode 100644 --- /dev/null +++ b/Bamse/Writer.hs @@ -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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 + } + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,8 @@ +module Main(main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain + + diff --git a/System/Path.hs b/System/Path.hs new file mode 100644 --- /dev/null +++ b/System/Path.hs @@ -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 diff --git a/Util/Dir.hs b/Util/Dir.hs new file mode 100644 --- /dev/null +++ b/Util/Dir.hs @@ -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 diff --git a/Util/GetOpts.hs b/Util/GetOpts.hs new file mode 100644 --- /dev/null +++ b/Util/GetOpts.hs @@ -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 + diff --git a/Util/List.hs b/Util/List.hs new file mode 100644 --- /dev/null +++ b/Util/List.hs @@ -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 + diff --git a/Util/Path.hs b/Util/Path.hs new file mode 100644 --- /dev/null +++ b/Util/Path.hs @@ -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 diff --git a/art/README.txt b/art/README.txt new file mode 100644 --- /dev/null +++ b/art/README.txt @@ -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 + diff --git a/art/banner.bmp b/art/banner.bmp new file mode 100644 Binary files /dev/null and b/art/banner.bmp differ diff --git a/art/banner2.bmp b/art/banner2.bmp new file mode 100644 Binary files /dev/null and b/art/banner2.bmp differ diff --git a/art/banner3.bmp b/art/banner3.bmp new file mode 100644 Binary files /dev/null and b/art/banner3.bmp differ diff --git a/art/bground.bmp b/art/bground.bmp new file mode 100644 Binary files /dev/null and b/art/bground.bmp differ diff --git a/art/bground2.bmp b/art/bground2.bmp new file mode 100644 Binary files /dev/null and b/art/bground2.bmp differ diff --git a/art/dlgbmp3rd.bmp b/art/dlgbmp3rd.bmp new file mode 100644 Binary files /dev/null and b/art/dlgbmp3rd.bmp differ diff --git a/art/galois-bground-fade.jpg b/art/galois-bground-fade.jpg new file mode 100644 Binary files /dev/null and b/art/galois-bground-fade.jpg differ diff --git a/art/galois-bground.JPG b/art/galois-bground.JPG new file mode 100644 Binary files /dev/null and b/art/galois-bground.JPG differ diff --git a/art/ghc-background-3rd.bmp b/art/ghc-background-3rd.bmp new file mode 100644 Binary files /dev/null and b/art/ghc-background-3rd.bmp differ diff --git a/art/ghc-background.bmp b/art/ghc-background.bmp new file mode 100644 Binary files /dev/null and b/art/ghc-background.bmp differ diff --git a/art/haskell-background.bmp b/art/haskell-background.bmp new file mode 100644 Binary files /dev/null and b/art/haskell-background.bmp differ diff --git a/art/haskell-banner.bmp b/art/haskell-banner.bmp new file mode 100644 Binary files /dev/null and b/art/haskell-banner.bmp differ diff --git a/bamse.cabal b/bamse.cabal new file mode 100644 --- /dev/null +++ b/bamse.cabal @@ -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 +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 +} diff --git a/data/license.rtf b/data/license.rtf new file mode 100644 Binary files /dev/null and b/data/license.rtf differ diff --git a/data/msi/Schema.msi b/data/msi/Schema.msi new file mode 100644 Binary files /dev/null and b/data/msi/Schema.msi differ diff --git a/data/msi/Sequence.msi b/data/msi/Sequence.msi new file mode 100644 Binary files /dev/null and b/data/msi/Sequence.msi differ diff --git a/data/msi/UISample.msi b/data/msi/UISample.msi new file mode 100644 Binary files /dev/null and b/data/msi/UISample.msi differ diff --git a/data/msi/base.msi b/data/msi/base.msi new file mode 100644 Binary files /dev/null and b/data/msi/base.msi differ diff --git a/doc/errors.txt b/doc/errors.txt new file mode 100644 --- /dev/null +++ b/doc/errors.txt @@ -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 "" + + 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. + diff --git a/doc/howto.html b/doc/howto.html new file mode 100644 --- /dev/null +++ b/doc/howto.html @@ -0,0 +1,64 @@ + + +Getting started with Bamse + + + +

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 the +using document 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, plus suggestions for improvements. +
+ +
+
+sof +
+ Last modified: Mon Oct 25 09:44:26 Pacific Daylight Time 2004 + diff --git a/doc/howto.txt b/doc/howto.txt new file mode 100644 --- /dev/null +++ b/doc/howto.txt @@ -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. diff --git a/doc/icons.txt b/doc/icons.txt new file mode 100644 --- /dev/null +++ b/doc/icons.txt @@ -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 + 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 + diff --git a/doc/index.html b/doc/index.html new file mode 100644 --- /dev/null +++ b/doc/index.html @@ -0,0 +1,77 @@ + + +Bamse: creating batch MSI emitters + + + +

Bamse: creating Windows MSI installers

+ +Bamse is a tool that arose out of the need to be able to create +Windows installers as part of an automated software build +process. +

+The result is available for you to hopefully also make good use of +in your software projects. It offers the following features: +

    +
  • Programmatic specification of installer builders.

    +By providing a Haskell module that tailors a general MSI installation +framework to the needs of your project, a command-line based +installer builder is produced. When invoked, it bundles +together the files and metadata that make up your installer, +outputting an MSI ready for distribution. +

    +

  • Authoring shell integration +

    +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. +

    +

  • Registry handling +

    +Should your application depend on the Registry for operation, +installation of Registry keys and values can easily be added. +

    +

  • Configurable UI +

    +The installation UI can easily be modified to include your own logos and +artwork. +

    +

  • High-level support for building installers for GHC library packages +

    +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. +

+ +

Downloading and installing

+ +Latest release: bamse-0.7
. 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. +

+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: + +

+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
+
+ +To get started with Bamse, have a look at the HOWTO. + +
+
+sof +
+ Last modified: Mon Sep 20 11:58:11 Pacific Daylight Time 2004 + diff --git a/doc/using.html b/doc/using.html new file mode 100644 --- /dev/null +++ b/doc/using.html @@ -0,0 +1,590 @@ + + +Creating Windows Installers + + + +

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 +] + +

API Summary

+ +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
+
+ +
+
+sof +
+ Last modified: Fri Sep 17 21:42:52 Pacific Standard Time 2004 + diff --git a/doc/using.txt b/doc/using.txt new file mode 100644 --- /dev/null +++ b/doc/using.txt @@ -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 + diff --git a/icons/cmdIcon.exe b/icons/cmdIcon.exe new file mode 100644 Binary files /dev/null and b/icons/cmdIcon.exe differ diff --git a/icons/folder.exe b/icons/folder.exe new file mode 100644 Binary files /dev/null and b/icons/folder.exe differ diff --git a/icons/hs.exe b/icons/hs.exe new file mode 100644 Binary files /dev/null and b/icons/hs.exe differ diff --git a/icons/hsx.exe b/icons/hsx.exe new file mode 100644 Binary files /dev/null and b/icons/hsx.exe differ diff --git a/icons/html.exe b/icons/html.exe new file mode 100644 Binary files /dev/null and b/icons/html.exe differ diff --git a/icons/html2.exe b/icons/html2.exe new file mode 100644 Binary files /dev/null and b/icons/html2.exe differ diff --git a/icons/pdf.exe b/icons/pdf.exe new file mode 100644 Binary files /dev/null and b/icons/pdf.exe differ diff --git a/icons/star.exe b/icons/star.exe new file mode 100644 Binary files /dev/null and b/icons/star.exe differ diff --git a/icons/txt.exe b/icons/txt.exe new file mode 100644 Binary files /dev/null and b/icons/txt.exe differ diff --git a/license.rtf b/license.rtf new file mode 100644 Binary files /dev/null and b/license.rtf differ diff --git a/templates/Alex.hs b/templates/Alex.hs new file mode 100644 --- /dev/null +++ b/templates/Alex.hs @@ -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 = [] diff --git a/templates/Bamse.hs b/templates/Bamse.hs new file mode 100644 --- /dev/null +++ b/templates/Bamse.hs @@ -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) + ] +-} diff --git a/templates/Base.hs b/templates/Base.hs new file mode 100644 --- /dev/null +++ b/templates/Base.hs @@ -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 = [] diff --git a/templates/ComPkg.hs b/templates/ComPkg.hs new file mode 100644 --- /dev/null +++ b/templates/ComPkg.hs @@ -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 = [] diff --git a/templates/Cryptol.hs b/templates/Cryptol.hs new file mode 100644 --- /dev/null +++ b/templates/Cryptol.hs @@ -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 "$" + +-- 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 = [] diff --git a/templates/GHC.hs b/templates/GHC.hs new file mode 100644 --- /dev/null +++ b/templates/GHC.hs @@ -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 = [] diff --git a/templates/GaloisPkg.hs b/templates/GaloisPkg.hs new file mode 100644 --- /dev/null +++ b/templates/GaloisPkg.hs @@ -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 = [] + diff --git a/templates/Greencard.hs b/templates/Greencard.hs new file mode 100644 --- /dev/null +++ b/templates/Greencard.hs @@ -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 = [] diff --git a/templates/HDirectLib.hs b/templates/HDirectLib.hs new file mode 100644 --- /dev/null +++ b/templates/HDirectLib.hs @@ -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 = [] diff --git a/templates/Haddock.hs b/templates/Haddock.hs new file mode 100644 --- /dev/null +++ b/templates/Haddock.hs @@ -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 = [] diff --git a/templates/Happy.hs b/templates/Happy.hs new file mode 100644 --- /dev/null +++ b/templates/Happy.hs @@ -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 = [] diff --git a/templates/Hugs98.hs b/templates/Hugs98.hs new file mode 100644 --- /dev/null +++ b/templates/Hugs98.hs @@ -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 = [] diff --git a/templates/Hugs98Net.hs b/templates/Hugs98Net.hs new file mode 100644 --- /dev/null +++ b/templates/Hugs98Net.hs @@ -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 = [] diff --git a/templates/PubCryptol.hs b/templates/PubCryptol.hs new file mode 100644 --- /dev/null +++ b/templates/PubCryptol.hs @@ -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 "$" + +-- 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 = [] diff --git a/templates/SOE.hs b/templates/SOE.hs new file mode 100644 --- /dev/null +++ b/templates/SOE.hs @@ -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 + diff --git a/tools/Makefile b/tools/Makefile new file mode 100644 --- /dev/null +++ b/tools/Makefile @@ -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) diff --git a/tools/README.txt b/tools/README.txt new file mode 100644 --- /dev/null +++ b/tools/README.txt @@ -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 diff --git a/tools/msiIcon.c b/tools/msiIcon.c new file mode 100644 --- /dev/null +++ b/tools/msiIcon.c @@ -0,0 +1,252 @@ +/* + * Utility for selecting and extracting an icon resource from a .DLL/.EXE/.ICO + * + * Usage: msiIcon + * + * creates .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 +#include +#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 \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 \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; +} diff --git a/tools/msiIcon.h b/tools/msiIcon.h new file mode 100644 --- /dev/null +++ b/tools/msiIcon.h @@ -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 +