-------------------------------------------------------------------- -- | -- Module : Bamse.DiaWriter -- Description : Converting a Dialog type into an MSI dialog. -- Copyright : (c) Sigbjorn Finne, 2004-2009 -- License : BSD3 -- -- Maintainer : Sigbjorn Finne -- Stability : provisional -- Portability : portable -- -- Converting a Dialog type into an MSI dialog. -- -------------------------------------------------------------------- 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 -> Bool -> Dialog -> IM () writeDialog pkg hasLicense (Dialog diaName cs conds evs (hc,vc) (w,h) attrs ttle 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 ttle) , "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") | isJust (p_cabalPackage pkg) -> ("CabalDialog", afterDlgCond) | otherwise -> (afterDlg, afterDlgCond) "CustomizeDlg" -> (afterDlg, afterDlgCond) _ -> (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" -> if diaName == "SetupKindDialog" && isJust (p_cabalPackage pkg) then "CabalDialog" else "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) mapM_ (\ act -> do addRow (act [ "Action" -=> Just (string "INSTALLGHCPKG") , "Condition" -=> Just (string ("NOT Installed AND RUNPKGMGR=1")) , "Sequence" -=> Just (int 6601) ]) addRow (act [ "Action" -=> Just (string "UNINSTALL_GHC_PKG") , "Condition" -=> Just (string "REMOVE") , "Sequence" -=> Just (int 6602) ])) [ newAdminExecuteSequence , newInstallExecuteSequence ] 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)) ]) 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)) ]) setupCabalPackage :: CabalPackage -> IM () setupCabalPackage pkg = do mapM_ (\ act -> do addRow (act [ "Action" -=> Just (string "CONFIGCABAL") , "Condition" -=> Just (string ("NOT Installed AND BUILDCABAL=1")) , "Sequence" -=> Just (int 6601) ]) addRow (act [ "Action" -=> Just (string "BUILDCABAL") , "Condition" -=> Just (string ("NOT Installed AND BUILDCABAL=1")) , "Sequence" -=> Just (int 6602) ]) addRow (act [ "Action" -=> Just (string "INSTALLCABAL") , "Condition" -=> Just (string ("NOT Installed AND BUILDCABAL<>1 AND RUNPKGMGR=1")) , "Sequence" -=> Just (int 6603) ]) addRow (act [ "Action" -=> Just (string "INSTALLCABAL2") , "Condition" -=> Just (string ("NOT Installed AND BUILDCABAL=1 AND RUNPKGMGR=1")) , "Sequence" -=> Just (int 6603) ]) addRow (act [ "Action" -=> Just (string "UNINSTALL_CABAL") , "Condition" -=> Just (string "REMOVE") , "Sequence" -=> Just (int 6604) ])) [ newAdminExecuteSequence , newInstallExecuteSequence ] let opts = "" {- "-DTARGETDIR=\"[TARGETDIR]\\\"" ++ case cabal_pkgCmdLine pkg of Nothing -> [] Just v -> ' ':v -} {- Performing Cabal operations: * unable to invoke 'runghc' directly here (via a Type:50 custom action), as we have to be in the target directory to perform the operation. * provide a simple call wrapper instead that simply adjusts the CWD before invoking 'runghc'. It needs to be named "custWrap.exe" and present in the toplevel target directory. The source for it is in Wrapper.hs in the toplevel of the Bamse tree. -} fKey <- findExeFile "custWrap.exe" addRow (newCustomAction [ "Action" -=> Just (string "INSTALLCABAL") , "Type" -=> Just (int 18) , "Source" -=> Just (string fKey) -- "GHCPKG") , "Target" -=> Just (string ("[TARGETDIR] [GHCPKG] Setup install " ++ opts)) ]) addRow (newCustomAction [ "Action" -=> Just (string "INSTALLCABAL2") , "Type" -=> Just (int 18) , "Source" -=> Just (string fKey) -- "GHCPKG") , "Target" -=> Just (string ("[TARGETDIR] [GHCPKG] Setup install --builddir=ldist" ++ opts)) ]) addRow (newCustomAction [ "Action" -=> Just (string "CONFIGCABAL") , "Type" -=> Just (int 18) , "Source" -=> Just (string fKey) , "Target" -=> Just (string ("[TARGETDIR] [GHCPKG] Setup configure --builddir=ldist" ++ opts)) ]) addRow (newCustomAction [ "Action" -=> Just (string "BUILDCABAL") , "Type" -=> Just (int 18) , "Source" -=> Just (string fKey) -- "GHCPKG") , "Target" -=> Just (string ("[TARGETDIR] [GHCPKG] Setup build --builddir=ldist")) ]) -- ToDo: fix addRow (newCustomAction [ "Action" -=> Just (string "UNINSTALL_CABAL") -- ignore errors , "Type" -=> Just (int (50+64)) , "Source" -=> Just (string "GHCPKG") , "Target" -=> Just (string ("unregister " ++ cabal_packageName pkg)) ]) addControl :: String -> Control -> IM () addControl diaName (Control cname ty pName (x,y) (w,h) text as next help) = do addRow (newControl [ "Dialog_" -=> Just (string diaName) , "Control" -=> Just (string cname) , "Type" -=> Just (string $ toControlTypeString ty) , "X" -=> Just (int x) , "Y" -=> Just (int y) , "Width" -=> Just (int width) , "Height" -=> Just (int height) , "Attributes" -=> Just (int $ flattenAttr 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 flattenAttr ats = fromIntegral (foldr marshal (0::Int32) ats) 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 mx acc = acc .|. case mx 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 tx = case tx 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 :: String -> (String, ControlEvent, String, String) -> IM () 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 :: String -> (String, String, String) -> IM () 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 _ -> '[':p ++ "]" ActionData -> "ActionData" ActionText -> "ActionText" AddLocal{} -> "AddLocal" AddSource{} -> "AddSource" CheckExistingTargetPath{} -> "CheckExistingTargetPath" CheckTargetPath{} -> "CheckTargetPath" DirectoryListNew -> "DirectoryListNew" DirectoryListOpen -> "DirectoryListOpen" DirectoryListUp -> "DirectoryListUp" DoAction{} -> "DoAction" EnableRollback{} -> "EnableRollback" EndDialog{} -> "EndDialog" IgnoreChange -> "IgnoreChange" NewDialog{} -> "NewDialog" Reinstall{} -> "Reinstall" ReinstallMode{} -> "ReinstallMode" Remove{} -> "Remove" Reset -> "Reset" ScriptInProgress -> "ScriptInProgress" SelectionAction -> "SelectionAction" SelectionBrowse -> "SelectionBrowse" SelectionDescription -> "SelectionDescription" SelectionIcon -> "SelectionIcon" SelectionNoItems -> "SelectionNoItems" SelectionPath -> "SelectionPath" SelectionPathOn -> "SelectionPathOn" SelectionSize -> "SelectionSize" SetInstallLevel{} -> "SetInstallLevel" SetProgress -> "SetProgress" SetTargetPath{} -> "SetTargetPath" SpawnDialog{} -> "SpawnDialog" SpawnWaitDialog{} -> "SpawnWaitDialog" TimeRemaining -> "TimeRemaining" ValidateProductID -> "ValidateProductID" toEventArg :: ControlEvent -> Maybe ColumnValue toEventArg ce = case ce 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