diff --git a/Bamse/Builder.hs b/Bamse/Builder.hs --- a/Bamse/Builder.hs +++ b/Bamse/Builder.hs @@ -9,13 +9,19 @@ -- Stability : provisional -- Portability : portable -- --- Toplevel module for bamse library/app. --- --- ToDo: --- - ability to organise installed bits into features/sub parts. +-- Toplevel module for the @Bamse@ library/app. Use @genBuilder@ +-- to do the generation of an MSI; it taking a specification of the +-- installer you are wanting to create. That along with the command-line +-- settings are then used to kick off the creation of an MSI database, +-- which will incorporate not only the metadata (installer name, shortcuts etc.) +-- but also the file content and structure that makes up the tree of +-- files you want to install on the user's machine. -- -------------------------------------------------------------------- -module Bamse.Builder ( genBuilder ) where +module Bamse.Builder + ( genBuilder + , genBuilderArgs + ) where import Bamse.Package import Bamse.Writer @@ -26,36 +32,51 @@ 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.FilePath +import Bamse.Util.Dir +import Bamse.Util.List ( ifCons ) -import System -import IO -import Monad ( when ) -import Maybe +import System.Cmd +import System.IO +import Data.Maybe import Bamse.Options import System.Directory +-- ToDo: +-- - ability to organise installed bits into features/sub parts. +-- + +-- | @genBuilderArgs pkg argv@ constructs an MSI from the given package +-- description + a set of command-line of arguments @args@. +genBuilderArgs :: PackageData -> [String] -> IO () +genBuilderArgs pkg args = do + opts <- getOptionsFrom args (p_defOutFile pkg) + genBuilderOpts pkg opts + +-- | @genBuilder pkg @ constructs an MSI from the given package +-- description, plus taking the command-line arguments from @getArgs@. genBuilder :: PackageData -> IO () genBuilder pkg = do putStrLn ("Installer builder for: " ++ name (p_pkgInfo pkg)) >> hFlush stdout opts <- getOptions (p_defOutFile pkg) + genBuilderOpts pkg opts + +genBuilderOpts :: PackageData -> Options -> IO () +genBuilderOpts pkg opts = do 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 + (dsDist, _ienv) <- mkDistTree (opt_ienv opts) + (normalise $ dropTrailingPathSeparator $ 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) $ + ifCons (p_userInstall pkg) setupTypeDialog $ + ifCons (isJust (p_cabalPackage pkg)) (cabalDialog (fromJust (p_cabalPackage pkg))) $ +--retired: ifCons (isJust (p_ghcPackage pkg)) ghcPkgDialog $ -- add customization selection dialog only if the -- builder supplies the relevant features. - case options (opt_ienv opts) of + case options_ (opt_ienv opts) of [] -> [] os -> [customizeDialog os] , p_productGUID = fromJust (opt_productGUID opts) @@ -66,18 +87,18 @@ let bamseDir = toolDir (p_ienv pkg') coRun $ do (_, ts, tabs, reps) <- doInstall [] (genTables pkg') - let env = + let wenv = 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_srcDir = normalise (takeDirectory (srcDir $ p_ienv pkg')) , w_package = pkg' } - outputMSI env tabs ts reps + outputMSI wenv tabs ts reps return () where - options ienv + options_ ienv = ifCons (not (null (p_extensions pkg ienv))) ("Register file extensions", "OptFileExt", True) $ ifCons (not (null (p_desktopShortcuts pkg ienv))) @@ -101,16 +122,16 @@ let outDir = appendP fp (appendP "out" nm) catch (createDirectory outDir) (\ _ -> return ()) copyOver outDir ds - ds <- allFiles outDir - return (ds, ienv{srcDir=outDir}) + ds1 <- allFiles outDir + return (ds1, 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") + Nothing -> return () + Just fnm -> do + let cmd = ("copy /b \"" ++ fnm ++ "\" \"" ++ + appendP outDir (dropDirPrefix topDir fnm) ++ "\" > nul") system cmd return () copyOver outDir (Directory fp subs) = do @@ -119,4 +140,4 @@ (fn fp) mapM_ (copyOver outDir) subs - appendP a b = toPlatformPath $ appendPath a b + appendP a b = normalise (a b) diff --git a/Bamse/DiaWriter.hs b/Bamse/DiaWriter.hs --- a/Bamse/DiaWriter.hs +++ b/Bamse/DiaWriter.hs @@ -14,7 +14,7 @@ -------------------------------------------------------------------- module Bamse.DiaWriter where -import Bamse.Dialog +--import Bamse.Dialog import Bamse.MSITable import Bamse.IMonad import Bamse.Package @@ -24,11 +24,11 @@ import Data.Bits import Data.Maybe -writeDialog :: PackageData -> Maybe GhcPackage -> Bool -> Dialog -> IM () -writeDialog pkg ghcPackage hasLicense +writeDialog :: PackageData -> Bool -> Dialog -> IM () +writeDialog pkg hasLicense (Dialog diaName cs conds evs (hc,vc) (w,h) attrs - title first def cancel + ttle first def cancel afterDlg afterDlgCond props) = do addRow (newDialog [ "Dialog" -=> Just (string diaName) , "HCentering" -=> Just (int hc) @@ -36,7 +36,7 @@ , "Width" -=> Just (int w) , "Height" -=> Just (int h) , "Attributes" -=> Just (int (flattenAttrib attrs)) - , "Title" -=> Just (string title) + , "Title" -=> Just (string ttle) , "Control_First" -=> Just (string first) , "Control_Default" -=> Just (string def) , "Control_Cancel" -=> Just (string cancel) @@ -52,8 +52,11 @@ | 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") @@ -73,7 +76,10 @@ -- used to follow (ditto for its Back button.) let nextDlg = case afterDlg of - "WelcomeDlg" -> "SetupTypeDlg" + "WelcomeDlg" -> + if diaName == "SetupKindDialog" && isJust (p_cabalPackage pkg) + then "CabalDialog" + else "SetupTypeDlg" "SetupKindDialog" -> "SetupTypeDlg" "CustomizeDlg" -> "VerifyReadyDlg" _ -> error ("unknown/unsupported dialog: " ++ afterDlg) @@ -83,7 +89,7 @@ , "Argument" -=> Just (string nextDlg) , "Condition" -=> Just (string "1") -- "NOT Installed" ])) - ioToIM (print (nextDlg,diaName)) +-- ioToIM (print (nextDlg,diaName)) addRow (newControlEvent [ "Dialog_" -=> Just (string nextDlg) -- "SetupTypeDlg" , "Control_" -=> Just (string "Back") , "Event" -=> Just (string "NewDialog") @@ -99,22 +105,11 @@ 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 -> + mapM_ (\ act -> do 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) @@ -122,6 +117,13 @@ [ 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 @@ -134,17 +136,95 @@ , "Target" -=> Just (string ("-u -i \"[TARGETDIR]"++pkg_file++"\" " ++ opts)) ]) -addControl diaName (Control name ty pName +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 name) + , "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 $ flattenAttrib as) + , "Attributes" -=> Just (int $ flattenAttr as) , "Property" -=> fmap string pName , "Text" -=> mbString text , "Control_Next" -=> mbString next @@ -158,7 +238,7 @@ _ -> return () where - flattenAttrib as = fromIntegral (foldr marshal (0::Int32) as) + flattenAttr ats = fromIntegral (foldr marshal (0::Int32) ats) addCheckBox onYes = do addRow (newCheckBox [ "Property" -=> fmap string pName @@ -183,8 +263,8 @@ , "Text" -=> Just (string txt) ]) - marshal x acc = acc .|. - case x of + marshal mx acc = acc .|. + case mx of Visible -> 0x01 Enabled -> 0x02 Sunken -> 0x04 @@ -228,7 +308,7 @@ IconSize48 -> 0x00600000 -- radio button group attributes HasBorder -> 0x01000000 - _ -> 0x0 +-- _ -> 0x0 {- BillboardName String @@ -240,8 +320,8 @@ TimeRemaining Int -} - toControlTypeString x = - case x of + toControlTypeString tx = + case tx of PushButton{} -> "PushButton" PathEdit -> "PathEdit" Line{} -> "Line" @@ -250,12 +330,13 @@ Bitmap{} -> "Bitmap" RadioButtonGroup{} -> "RadioButtonGroup" CheckBox{} -> "CheckBox" - _ -> error ("toControlTypeString: unhandled control ") + _ -> 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) @@ -265,6 +346,7 @@ , "Ordering" -=> mbString ordering ]) +addControlCondition :: String -> (String, String, String) -> IM () addControlCondition diaName (cName, action, cond) = addRow (newControlCondition [ "Dialog_" -=> Just (string diaName) , "Control_" -=> Just (string cName) @@ -312,8 +394,8 @@ ValidateProductID -> "ValidateProductID" toEventArg :: ControlEvent -> Maybe ColumnValue -toEventArg x = - case x of +toEventArg ce = + case ce of SetProperty _ "" -> Just (string "{}") SetProperty _ x -> Just (string x) AddLocal f -> Just (string f) diff --git a/Bamse/DialogUtils.hs b/Bamse/DialogUtils.hs --- a/Bamse/DialogUtils.hs +++ b/Bamse/DialogUtils.hs @@ -14,18 +14,19 @@ -------------------------------------------------------------------- module Bamse.DialogUtils ( ghcPkgDialog -- :: Dialog + , cabalDialog -- :: Dialog , setupTypeDialog -- :: Dialog , customizeDialog -- :: Dialog ) where ---import Bamse.Package +import Bamse.GhcPackage 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" + "WARNING: unable to locate 'ghc-pkg'; automatic installation not available" [Transparent,Enabled] "" "") $ addCond ("Msg", "Show", "GHCPKGDIR=\"\"") $ @@ -37,11 +38,39 @@ [ ("Yes", "1") , ("No", "0") ] - "RUNPKGMGR" + ("InstallKind","RUNPKGMGR") + Nothing "WelcomeDlg" "NOT Installed" - ("InstallKind", "2") + [("InstallKind", "2")] +cabalDialog :: CabalPackage -> Dialog +cabalDialog pkg = + addControl (Control "Msg" (Text "foo") Nothing + (40,180) (180,40) + "WARNING: unable to locate 'runghc'; automatic installation not available" + [Transparent,Enabled] + "" "") $ + addCond ("Msg", "Show", "GHCPKG=\"\"") $ + addCond ("RegKind", "Disable", "GHCPKG=\"\"") $ + (if (cabal_fromSource pkg) + then addCond ("BuildKind", "Disable", "GHCPKG=\"\"") + else id) $ + mkChoiceDialog "CabalDialog" + "Cabal package installation" + "{\\VerdanaBold13}Select Cabal package installation type" + "The installer can automatically register the package; do you want to?" + yesNos + ("RegKind","RUNPKGMGR") + (if (cabal_fromSource pkg) + then (Just (yesNos,"Do you also want to configure and build from source?" ,("BuildKind","BUILDCABAL"))) + else Nothing) + "WelcomeDlg" + "NOT Installed" + (("RegKind", "2") :(if cabal_fromSource pkg then [("BuildKind", "2")] else [])) + where + yesNos= [ ("Yes", "1"), ("No", "0") ] + setupTypeDialog :: Dialog setupTypeDialog = -- Hack: ALLUSERS needs to be undefined in order @@ -59,10 +88,11 @@ [ ("Just for me", "0") , ("Everyone", "2") ] - "InstallKind" + ("InstallKind","InstallKind") + Nothing "WelcomeDlg" "NOT Installed" - ("InstallKind", "2") + [("InstallKind", "2")] -- dialog for letting the user control the level of shell integration -- to use (file extensions, start menu, desktop shortcuts.) @@ -142,14 +172,15 @@ -> String -- title -> String -- description -> [(String, String)] - -> PropertyName + -> (String, PropertyName) + -> Maybe ([(String, String)], String, (String,PropertyName)) -> DialogName -> String - -> (PropertyName, String) + -> [(PropertyName, String)] -> Dialog mkChoiceDialog diaNm diaHeader diaTitle diaDesc opts - propName afterDiag afterDiagCond - (initProp, initVal) + (ctrlName,propName) mbSnd afterDiag afterDiagCond + initVals = Dialog { dia_name = diaNm , dia_ctrls = controls , dia_conds = conditions @@ -163,7 +194,7 @@ , dia_cancel = "cancelButton" , dia_after = afterDiag , dia_cond = afterDiagCond - , dia_props = [(initProp, initVal)] + , dia_props = initVals } where controls @@ -182,16 +213,34 @@ (0,0) (370,234) "[DialogBitmap]" [Visible] "Back" "" - , Control "InstallKind" + , Control ctrlName (RadioButtonGroup (map (\(txt,val) -> RadioButton txt val) opts)) (Just propName) - (130,120) (180,40) "" + (130,95) (radioTextWidth opts,40) "" [{-Transparent,-}Enabled,Visible] "" "" - ] + ] ++ + case mbSnd of + Nothing -> [] + Just (opts2,dd,(cName,bPropName)) -> + [ Control ("Description_"++cName) (Text "foo") Nothing + (125,140) (220,60) + dd + [Transparent, NoPrefix, Enabled, Visible] + "" "" + , Control cName + (RadioButtonGroup (map (\(txt,val) -> RadioButton txt val) opts2)) + (Just bPropName) + (130,160) (radioTextWidth opts,40) "" + [{-Transparent,-}Enabled,Visible] + "" "" ] + conditions = [] events = [ ("cancelButton", EndDialog "Exit", "1", "1") ] + + radioTextWidth ls = 10 + 10*maximum (map (length.fst) ls) + addEvent :: CEvent -> Dialog -> Dialog addEvent ev d = d{dia_events=ev:dia_events d} diff --git a/Bamse/GhcPackage.hs b/Bamse/GhcPackage.hs --- a/Bamse/GhcPackage.hs +++ b/Bamse/GhcPackage.hs @@ -9,7 +9,8 @@ -- Stability : provisional -- Portability : portable -- --- Specifying the contents of a GHC package. +-- Specifying the contents of a GHC package...uh, more Cabal nowadays :-) +-- (the GHC package support has effectively been disabled\/retired.) -- -------------------------------------------------------------------- module Bamse.GhcPackage where @@ -22,7 +23,21 @@ , 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_. + -- ^ Extra command-line options to feed @ghc-pkg@ when /installing/. -- more to follow.. -- , ghc_stuff :: String + } + +data CabalPackage + = CabalPackage + { cabal_packageName :: String + -- ^ Name of the package; this must match the one in the .pkg file. + , cabal_forGhcVersion :: String + -- ^ What version of GHC to install the package for. + , cabal_packageFile :: Maybe FilePath + -- ^ Dist-tree local path to .pkg file + , cabal_pkgCmdLine :: Maybe [(String, String)] + -- ^ Extra command-line options to feed @ghc-pkg@ when performing a particular verb. + , cabal_fromSource :: Bool + -- ^ Set to @True@ if you want to support from-source building } diff --git a/Bamse/IMonad.hs b/Bamse/IMonad.hs --- a/Bamse/IMonad.hs +++ b/Bamse/IMonad.hs @@ -31,6 +31,8 @@ , addFile , replaceFile , getFiles + + , findExeFile , Id ) where @@ -40,6 +42,8 @@ import System.IO.Unsafe ( unsafeInterleaveIO ) import Data.List +import System.FilePath + type Id = String data IState @@ -139,6 +143,7 @@ newId = IM $ \ st -> case istate_guids st of (g:gs) -> return (show g, st{istate_guids=gs}) + [] -> error "the GUID Store ran out of uniques; how weird." -- an infinite supply of GUIDs. new_guids :: IO [GUID] @@ -147,3 +152,11 @@ xs <- unsafeInterleaveIO new_guids return (x : xs) +findExeFile :: String -> IM String +findExeFile t = do + ls <- getFiles + let ls' = map (\ st@(x,_) -> (x,st)) ls ++ map (\ st@(x,_) -> (System.FilePath.takeFileName x, st)) ls + case lookup t ls' of + Nothing -> do + ioToIM (fail ("ERROR: findExeFile, unable to locate target file: " ++ show t)) + Just (_,(fKey,_,_,_)) -> return fKey diff --git a/Bamse/MSIExtra.hs b/Bamse/MSIExtra.hs --- a/Bamse/MSIExtra.hs +++ b/Bamse/MSIExtra.hs @@ -17,8 +17,8 @@ module Bamse.MSIExtra where import Data.Char ( toUpper ) -import Util.Path ( fileSuffix ) import Bamse.Package +import System.FilePath ( takeExtension ) -- product ID tags (from MsiDefs.h, not provided in the TLB). data ProductIDTag @@ -53,7 +53,7 @@ where badChars = " +,;=[]" restricted_nm = map (\ ch -> if ch `elem` badChars then '_' else ch) nm - ext = fileSuffix nm + ext = case System.FilePath.takeExtension nm of { '.':xs -> xs ; xs -> xs } short_form | length restricted_nm > 8 || length ext > 3 = take 6 (map toUpper restricted_nm) ++ "~1|" ++ nm | otherwise = restricted_nm diff --git a/Bamse/MSITable.hs b/Bamse/MSITable.hs --- a/Bamse/MSITable.hs +++ b/Bamse/MSITable.hs @@ -134,7 +134,7 @@ ) where -import Util.List +import Bamse.Util.List import Data.Maybe import Bamse.PackageUtils ( expandString ) @@ -155,6 +155,7 @@ ) type ColumnName = String +-- | 'ColumnType' type ColumnType = ( Bool -- True => NOT NULL. , Bool -- True => is primary key. diff --git a/Bamse/Options.hs b/Bamse/Options.hs --- a/Bamse/Options.hs +++ b/Bamse/Options.hs @@ -17,15 +17,18 @@ import Bamse.Package import Bamse.Writer ( getProductCodes ) -import System -import Util.GetOpts +import System.Environment +import System.Exit +import Bamse.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 ( newGUID, guidToString ) +import System.IO ( hPutStrLn, stderr, stdout ) +import System.Directory ( getCurrentDirectory ) +import Data.Maybe ( isNothing, fromJust, isJust ) +import Control.Monad ( when, foldM ) +import System.FilePath +--import Util.Path import System.Win32.Com.Base ( getModuleFileName ) import Foreign.Ptr ( nullPtr ) import Bamse.PackageUtils ( addEnvVar ) @@ -74,6 +77,7 @@ , opt_defines = [] } +versionStr :: String versionStr = "" help :: String -> String @@ -121,114 +125,128 @@ toGUID xs@('{':_) = xs -- '}' toGUID ls = '{':ls ++ "}" +helpError :: IO a helpError = do showHelp exitWith (ExitFailure 1) +showHelp :: IO () showHelp = do p <- getProgName hPutStrLn stderr (help p) validateOptions :: FilePath -> Options -> [FilePath] -> IO Options -validateOptions defOut opts inps = do +validateOptions defOut opts0 inps = do + foldM (\ o f -> f o) + opts0 + [ topInstallTree + , outputReqd + , productGUIDReqd + , revisionGUIDReqd + , dataDirReqd + ] + where -- 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 + topInstallTree opts + | not (opt_showInfo opts) && isNothing (opt_srcDir opts) && length inps /= 1 = helpError + | isNothing (opt_srcDir opts) = return opts{opt_srcDir=Just (head inps)} + | otherwise = 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 + outputReqd opts + | not (opt_update opts) || isJust (opt_outFile opts) = return opts + | otherwise = do + let opts' = opts{opt_outFile=Just defOut} + hPutStrLn stderr ("WARNING: no output file given, using: " ++ fromJust (opt_outFile opts')) + 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 + productGUIDReqd opts + | opt_update opts || opt_showInfo opts = return opts + | opt_genGUIDs opts = do + g <- newGUID + let n = guidToString g + n `seq` return opts{opt_productGUID=Just n} + | isNothing (opt_productGUID opts) = do + hPutStrLn stderr ("ERROR: missing product GUID option") + helpError + | otherwise = return opts + + revisionGUIDReqd opts + | (opt_update opts) || (opt_showInfo opts) = return opts + | opt_genGUIDs opts = do + g <- newGUID + let n = guidToString g + n `seq` return opts{opt_revisionGUID=Just n} + | isNothing (opt_revisionGUID opts) = do + hPutStrLn stderr ("ERROR: missing revision GUID option") + helpError + | otherwise = return opts + + dataDirReqd opts + | isJust (opt_dataDir opts) = return opts + | otherwise = 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) + getOptionsFrom ls defOut + +getOptionsFrom :: [String] -> FilePath -> IO Options +getOptionsFrom args defOut = do + (opts0, inps) <- parseArgs args + opts1 <- validateOptions defOut opts0 inps + opts2 <- + if not (opt_update opts1) && not (opt_showInfo opts1) + then return opts1 + else do + (a,b) <- getProductCodes (fromJust (opt_outFile opts1)) ; + return opts1{ opt_productGUID = Just a + , opt_revisionGUID = Just b + } + + when (opt_help opts2) (showHelp >> exitWith ExitSuccess) + when (opt_version opts2) (hPutStrLn stderr versionStr >> exitWith ExitSuccess) + when (opt_showInfo opts2) $ do + hPutStrLn stdout $ "Product code: " ++ fromJust (opt_productGUID opts2) + hPutStrLn stdout $ "Revision code: " ++ fromJust (opt_revisionGUID opts2) exitWith ExitSuccess - mapM_ processDefine (opt_defines opts) + os <- mapM processDefine (opt_defines opts2) + cwd <- getCurrentDirectory let - srcDir = - case opt_srcDir opts of + sourceDir = + case opt_srcDir opts2 of Nothing -> error "no srcDir" - Just x -> toPlatformPath (joinPath $ splitPath x) + Just x + | isAbsolute x -> normalise (dropTrailingPathSeparator x) + | otherwise -> normalise $ + case normalise (dropTrailingPathSeparator x) of + "." -> cwd + "" -> cwd + y -> cwd y oFile = - case opt_outFile opts of - Nothing -> toPlatformPath defOut - Just x -> toPlatformPath x + case opt_outFile opts2 of + Nothing -> normalise defOut + Just x -> normalise x bfile <- getModuleFileName nullPtr - let bdir = toPlatformPath $ appendSep (dirname bfile) + let bdir = normalise (addTrailingPathSeparator (takeDirectory bfile)) let ienv = InstallEnv - { toolDir = bdir - , srcDir = srcDir - , distDir = error "distDir not filled in yet" - , outFile = oFile + { toolDir = maybe bdir id (opt_toolDir opts2) + , srcDir = sourceDir + , distDir = error "distDir not filled in yet" + , outFile = oFile + , userOpts = os } - return opts{opt_ienv=ienv} + return opts2{opt_ienv=ienv} -processDefine :: String -> IO () +processDefine :: String -> IO (String,String) processDefine str = case break (=='=') str of - (as,[]) -> addEnvVar as "" - (as,_:bs) -> addEnvVar as bs + (as,[]) -> addEnvVar as "" >> return (as,"") + (as,_:bs) -> addEnvVar as bs >> return (as,bs) + diff --git a/Bamse/Package.hs b/Bamse/Package.hs --- a/Bamse/Package.hs +++ b/Bamse/Package.hs @@ -18,14 +18,15 @@ ( module Bamse.Package , module Bamse.GhcPackage , module Bamse.Dialog + , module Bamse.Util.Dir ) where -import Util.Dir ( DirTree ) +import Bamse.Util.Dir import Bamse.Dialog import Bamse.GhcPackage -- --- The functions provided by a template are parameterised over +-- | 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 @@ -35,11 +36,12 @@ -- 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. + { 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. + , userOpts :: [(String,String)] -- invocation-time (name,value) pairs } deriving Show @@ -88,7 +90,9 @@ , p_productGUID :: String -- expected form: "{...}" , p_revisionGUID :: String -- ditto , p_nestedInstalls :: [(FilePath, Maybe String)] - , p_ghcPackage :: Maybe GhcPackage +-- , p_ghcPackage :: Maybe GhcPackage + , p_cabalPackage :: Maybe CabalPackage + , p_assemblies :: [Assembly] , p_ienv :: InstallEnv , p_verbose :: Bool } @@ -121,7 +125,9 @@ , p_services = fieldError "services" , p_productGUID = fieldError "productGUID" , p_revisionGUID = fieldError "revisionGUID" - , p_ghcPackage = fieldError "ghcPackage" +-- , p_ghcPackage = fieldError "ghcPackage" + , p_cabalPackage = fieldError "cabalPackage" + , p_assemblies = [] , p_nestedInstalls = fieldError "nestedInstalls" , p_ienv = fieldError "ienv" , p_verbose = fieldError "verbose" @@ -129,6 +135,45 @@ where fieldError f = error ("defPackageData.p_" ++ f ++ ": not filled in") +minimalPackageData :: PackageData +minimalPackageData = pkg + where + pkg = + PackageData { p_files = fieldError "files" + , p_fileMap = fieldError "fileMap" + , p_distFileMap = Nothing + , p_defOutFile = fieldError "defOutFile" + , p_pkgInfo = fieldError "pkgInfo" + , p_webSite = "" + , p_bannerBitmap = \ _ienv -> Nothing + , p_bgroundBitmap = \ _ienv -> Nothing + , p_registry = [] + , p_baseFeature = fieldError "baseFeature" + , p_features = [] + , p_featureMap = Nothing + , p_startMenu = \ _ienv -> ("",[]) + , p_desktopShortcuts = \ _ienv -> [] + , p_extensions = \ _ienv -> [] + , p_verbs = [] + , p_license = \ _ienv -> Nothing + , p_userRegistration = False + , p_defaultInstallFolder = Nothing + , p_userInstall = True + , p_dialogs = [] + , p_finalMessage = Nothing + , p_notForAll = False + , p_services = [] + , p_productGUID = fieldError "productGUID" + , p_revisionGUID = fieldError "revisionGUID" + , p_cabalPackage = fieldError "cabalPackage" + , p_assemblies = [] + , p_nestedInstalls = [] + , p_ienv = fieldError "ienv" + , p_verbose = False + } + + fieldError f = error ("minimalPackageData.p_" ++ f ++ ": not filled in") + -- various supporting types that don't quite belong here.. data Shortcut = Shortcut @@ -199,3 +244,29 @@ = Leaf a | Node a [Tree a] + +-- | @Assembly@ defines a reference to a local DLL that you +-- want to be treated as an assembly (and installed/registered as such.) +data Assembly + = Assembly + { assem_dll :: FilePath + , assem_manifest :: Maybe FilePath -- optional; preferably embedded in the assembly DLL as resource.. + , assem_privatePath :: Maybe FilePath -- if you don't want to install into GAC; untested.. + , assem_name :: String + , assem_version :: String + , assem_culture :: String + , assem_publicKey :: String + , assem_win32 :: Bool + } + +emptyAssembly :: Assembly +emptyAssembly = Assembly + { assem_dll = "" + , assem_manifest = Nothing + , assem_privatePath = Nothing + , assem_name = "" + , assem_version = "0.0.0.0" + , assem_culture = "" -- neutral + , assem_publicKey = "" + , assem_win32 = False -- MSIL in other words. + } diff --git a/Bamse/PackageGen.hs b/Bamse/PackageGen.hs --- a/Bamse/PackageGen.hs +++ b/Bamse/PackageGen.hs @@ -21,14 +21,16 @@ import Bamse.DiaWriter import Bamse.PackageUtils ( dropDirPrefix ) -import Util.Dir -import Util.Path -import Util.List +import Bamse.Util.Dir +--import Util.Path +import System.FilePath hiding ( addExtension ) +import Bamse.Util.List import Data.Maybe ( isJust, isNothing, fromJust ) +import Data.List ( inits ) import System.IO ( openFile, IOMode(..), hFileSize, hClose ) import Control.Monad ( when, zipWithM_ ) -import Debug.Trace +--import Debug.Trace -- fileSize :: FilePath -> IO Integer @@ -47,6 +49,7 @@ makeShortcutsOptional addFileExtensions (fst $ p_baseFeature pkg_data) (p_extensions pkg_data ienv) addVerbs (p_verbs pkg_data) + addAssemblies (p_baseFeature pkg_data) (p_assemblies pkg_data) configureLicense (p_license pkg_data ienv) setUserRegistration (p_userRegistration pkg_data) setCustomTargetDir (p_defaultInstallFolder pkg_data) @@ -59,18 +62,26 @@ 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)) + mapM_ (writeDialog pkg_data (isJust $ p_license pkg_data ienv)) (p_dialogs pkg_data) addFiles addFeatures (p_baseFeature pkg_data) (p_featureMap pkg_data) (p_features pkg_data) - addRegSearch (p_ghcPackage pkg_data) + addRegSearch (p_cabalPackage pkg_data) addServices (p_services pkg_data) + maybe (return ()) + (\ cp -> do + addDirOrFile pkg_data False (toolDir (p_ienv pkg_data) "tools" "custWrap.exe") + setupCabalPackage cp) + (p_cabalPackage pkg_data) +{- + when (isJust (p_ghcPackage pkg_data)) + (setupGhcPackage (fromJust (p_ghcPackage pkg_data))) +-} addNestedInstalls (p_nestedInstalls pkg_data) where ienv = p_ienv pkg_data +addServices :: [Service] -> IM () addServices ls = case ls of [] -> return () @@ -83,7 +94,7 @@ dirs <- getDirs comps <- getComponents let theBinary - | null (fileSuffix (serv_binary s)) = changeSuffix ".exe" (serv_binary s) + | null (takeExtension (serv_binary s)) = replaceExtension (serv_binary s) "exe" | otherwise = serv_binary s let cKey = findExeComponent dirs comps theBinary user_pwd = @@ -113,8 +124,7 @@ ])) -- All services that are installed will be removed during uninstall. -- Make it so. - v <- newId - let tKey = idToKey v + tKey <- newId >>= return.idToKey addRow (newServiceControl ([ "ServiceControl" -=> Just (string tKey) , "Name" -=> Just (string (serv_name s)) @@ -123,35 +133,53 @@ ])) -- testing Registry searching..look for a GHC installation. +addRegSearch :: Maybe CabalPackage -> IM () addRegSearch ghcPackage | isNothing ghcPackage = return () | otherwise = do let pkg = fromJust ghcPackage - sId <- newId - let installDirKey = idToKey sId - sId <- newId - let ghcPkgDirKey = idToKey sId + installDirKey <- newId >>= return.idToKey + ghcPkgDirKey <- newId >>= return.idToKey + gId <- newId + let ghcPkgKey = idToKey gId +{- + addRow (newSignature [ "Signature" -=> Just (string installDirKey) + , "FileName" -=> Just (string "README.txt") + ]) +-} + addRow (newSignature [ "Signature" -=> Just (string ghcPkgKey) + , "FileName" -=> Just (string "runghc.exe") + ]) +{- + addRow (newSignature [ "Signature" -=> Just (string ghcPkgDirKey) + , "FileName" -=> Just (string "bin") + ]) +-} + addRow (newAppSearch [ "Property" -=> Just (string "GHCPKG") + , "Signature_" -=> Just (string ghcPkgKey) + ]) addRow (newAppSearch [ "Property" -=> Just (string "GHCPKGDIR") , "Signature_" -=> Just (string ghcPkgDirKey) ]) - addRow (newAppSearch [ "Property" -=> Just (string "GhcInstallDir") + + addRow (newAppSearch [ "Property" -=> Just (string "InstallDir") , "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)) + , "Root" -=> Just (int 1) -- 1=HKCU; 2=HKLM + , "Key" -=> Just (string ("Software\\Haskell\\GHC\\ghc-"++ cabal_forGhcVersion pkg)) , "Name" -=> Just (string "InstallDir") - , "Type" -=> Just (int 2) -- 'Key' is a key. + , "Type" -=> Just (int 0) -- 'Key' is a directory. ]) 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") + , "Path" -=> Just (string "bin") + , "Depth" -=> Just (int 1) ]) - addRow (newSignature [ "Signature" -=> Just (string installDirKey) - , "FileName" -=> Just (string "ghc-pkg.exe") + addRow (newDrLocator [ "Signature_" -=> Just (string ghcPkgKey) + , "Parent" -=> Just (string ghcPkgDirKey) + , "Path" -=> Just (string "") + , "Depth" -=> Just (int 0) ]) -- @@ -163,9 +191,9 @@ 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 + Empty -> return () + Bamse.Util.Dir.File l -> addDirOrFile pkg False l + Directory dName subs -> addDirOrFile pkg True dName >> mapM_ (mkFileTables pkg) subs -- -- Function: addDirOrFile @@ -193,12 +221,12 @@ -- files.) -- addDirOrFile :: PackageData -> Bool -> FilePath -> IM () -addDirOrFile pkg isDir fPath = do +addDirOrFile pkg isDir fPath0 = do -- The 'controlling' directory of the file/dir. -- For a file, the parent dir; for a directory, itself. let dName - | isDir = fPath - | otherwise = dirname fPath + | isDir = normalise (dropTrailingPathSeparator fPath) + | otherwise = normalise (takeDirectory fPath) dirs <- getDirs let mbDir = lookupDirectory dName dirs fileKey <- @@ -220,19 +248,25 @@ -- first off, create the ancestors. let sDir = srcDir (p_ienv pkg) - let dNameRel = dropDirPrefix (dirname sDir) dName + let dNameRel = dropDirPrefix (takeDirectory sDir) dName createDirPath (p_verbose pkg) "TARGETDIR" (splitPath2 dNameRel) let parentDir ds = case lookupDirectory dNameRel ds of Just x -> x _ -> "TARGETDIR" - dirs <- getDirs - let dirKey = parentDir dirs - when (null (shortLong (baseName dName))) - (ioToIM (putStrLn ("empty: "++ show (dName, baseName dName)))) - if isSpecialFile + dirKey <- getDirs >>= return.parentDir + when (null (shortLong (takeFileName dName))) + (ioToIM (putStrLn ("empty: "++ show (dName, takeFileName dName)))) + if not isSpecialFile then do + comps <- getComponents + case mbFindDirComponent dirKey comps of + Just x -> return x + Nothing -> do + ioToIM (putStrLn ("INTERNAL ERROR: Component missing directory mapping: "++show (dName,sDir,dNameRel,dirKey))) + return "TARGETDIR" + else do compKey <- fmap idToKey newId compGUID <- newId dirKeyN <- newId @@ -252,23 +286,25 @@ , "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)) + addFile fPath fileKey compKey (shortLong (takeFileName fPath)) (show fsz)) where + fPath = normalise fPath0 isSpecialFile = isCompWorthy fPath -- Files with certain file extensions get put into sep. components. -- See 'addDirOrFile' comments as to why this is done. - isCompWorthy fpath = fileSuffix fpath `elem` ["exe", "dll", "ocx", "hlp"] + isCompWorthy fpath = takeExtension fpath `elem` [".exe", ".dll", ".ocx", ".hlp"] +splitPath2 :: FilePath -> [FilePath] +splitPath2 xs = map joinPath $ tail $ inits $ splitDirectories xs + -- Go down a directory path, adding components for directories -- that haven't been seen before. createDirPath :: Bool -> String -> [String] -> IM () @@ -297,7 +333,7 @@ [ "Directory" -=> Just (string dirKey) , "Directory_Parent" -=> Just (string parentDirKey) , "DefaultDir" -=> - Just (string ((if parent == "TARGETDIR" then (".:"++) else id) (shortLong (baseName d)))) + Just (string ((if parent == "TARGETDIR" then (".:"++) else id) (shortLong (takeFileName d)))) ]) addRow (newComponent [ "Component" -=> Just (string compKey) @@ -348,7 +384,10 @@ -> Maybe (FilePath -> FeatureName) -> [Tree Feature] -> IM () -addFeatures bFeat featMap fs = do +addFeatures bFeat featMap fs0 = do + let fs + | null fs0 = [Leaf bFeat] + | otherwise = fs0 zipWithM_ (addFeatureTree Nothing) fs [(1::Int),3..] ls <- getComponents case featMap of @@ -357,12 +396,12 @@ where baseFKey = idToKey (fst bFeat) - writeFeatMapComp f (compKey, compName) = do + writeFeatMapComp _ (compKey, _compName) = do addRow (newFeatureComponents [ "Feature_" -=> Just (string baseFKey) , "Component_" -=> Just (string compKey) ]) - writeFeatComp (compKey, compName) = do + writeFeatComp (compKey, _compName) = do addRow (newFeatureComponents [ "Feature_" -=> Just (string baseFKey) , "Component_" -=> Just (string compKey) ]) @@ -370,10 +409,10 @@ addFeatureTree parent tr lab = do case tr of Leaf f -> addFeature parent lab f - Node p@(id,_) fs -> do + Node p@(i,_) feats -> do addFeature parent lab p - zipWithM_ (\ f u -> addFeatureTree (Just (idToKey id)) f (lab*10+u)) - fs + zipWithM_ (\ f u -> addFeatureTree (Just (idToKey i)) f (lab*10+u)) + feats [(1::Int),3..] addFeature mbParent v (featName, featDesc) = do @@ -381,7 +420,7 @@ addRow (newFeature (("Feature" -=> Just (string featKey)) : (case mbParent of - Just v -> (("Feature_Parent" -=> Just (string v)):) + Just fp -> (("Feature_Parent" -=> Just (string fp)):) _ -> id) ( [ "Title" -=> Just (string featName) , "Description" -=> Just (string featDesc) @@ -394,10 +433,11 @@ lookupDirectory :: FilePath -> [(FilePath, Id)] -> Maybe Id lookupDirectory fPath ls = lookup fPath ls +findExeComponent :: [(FilePath, String)] -> [(FilePath,String)] -> FilePath -> FilePath findExeComponent dirs comps fpath = -- be a bit flexible here & allow basename of the -- app targets to be used. - let dirs' = dirs ++ mapFst baseName dirs in + let dirs' = dirs ++ mapFst takeFileName dirs in case lookup fpath dirs' of Just c -> case lookup c (map swap comps) of @@ -406,17 +446,19 @@ Nothing -> fpath _ -> fpath +findDirComponent :: String -> [(String, String)] -> String findDirComponent dir comps = - case lookup dir (map swap comps) of - -- want to map a dir to a comp, so swap (comp,dir) pairs. + case mbFindDirComponent dir comps of Just x -> x Nothing -- | dir == "TARGETDIR" -> "TARGETDIR" | otherwise -> error ("findDirComponent: couldn't locate " ++ show dir) -- want to map a dir to a comp, so swap (comp,dir) pairs. +mbFindDirComponent :: String -> [(String, String)] -> Maybe String mbFindDirComponent dir comps = lookup dir (map swap comps) +swap :: (a,b) -> (b,a) swap (a,b) = (b,a) -- convert a unique (quite possibly, a GUID) Id into the key @@ -453,7 +495,7 @@ addCompMapping cKey "TARGETDIR" mapM_ (writeReg cKey cId) rs where - writeReg cKey cId (RegEntry hive key kAction) = do + writeReg cKey _cId (RegEntry hive hkey kAction) = do rName <- newId let rKey = idToKey rName (nm, val) = keyAction kAction @@ -468,7 +510,7 @@ addRow (newRemoveRegistry [ "RemoveRegistry" -=> Just (string rKey) , "Root" -=> Just (string (toHiveId hive)) - , "Key" -=> Just (string key) + , "Key" -=> Just (string hkey) , "Name" -=> fmap string nm , "Component_" -=> Just (string cKey) ]) @@ -476,7 +518,7 @@ addRow (newRegistry [ "Registry" -=> Just (string rKey) , "Root" -=> Just (string (toHiveId hive)) - , "Key" -=> Just (string key) + , "Key" -=> Just (string hkey) , "Name" -=> fmap string nm , "Value" -=> fmap string val , "Component_" -=> Just (string cKey) @@ -538,9 +580,10 @@ ]) -- and our app folder(s). let dirs = split '/' appFolders + + createDirs _ [] = error "createDirs: empty list; unexpected.." createDirs pKey [d] = do - i <- newId - let appKey = idToKey i + appKey <- newId >>= return.idToKey addRow (newDirectory [ "Directory" -=> Just (string appKey) , "Directory_Parent" -=> Just (string pKey) @@ -564,6 +607,7 @@ mapM_ (addShortcut appKey) scuts' +makeShortcutsOptional :: IM () makeShortcutsOptional = do -- Make the installation of shortcuts dependent on _either_ OptStartMenu or -- OptDesktopShortCuts being set to Yes. I don't see how to achieve the @@ -609,34 +653,35 @@ The user refers to the target of the shortcut by (file)name; the MSI wants to know the component (of that file). -} +adjustTarget :: InstallEnv -> Id -> Shortcut -> IM (String, Shortcut) adjustTarget ienv feat s = do dirs <- getDirs comps <- getComponents -- Try interpreting 'scut_target' as a directory relative to the srcDir. - -- The directory list is recorded as relative to 'baseName' of the srcDir, + -- The directory list is recorded as relative to 'takeFileName' of the srcDir, -- so pin this in front of the user-specified directory. - let bdir = baseName (srcDir ienv) - let t = scut_target s + let bdir = takeFileName (srcDir ienv) + let tgt = scut_target s let tdir - | null t = bdir - | otherwise = appendPath bdir t + | null tgt = bdir + | otherwise = normalise (bdir tgt) -- Note: no need to put a slash between the two (indeed, it's harmful.) - let odir = "[TARGETDIR]" ++ t + let odir = "[TARGETDIR]" ++ tgt let mbDir = lookupDirectory tdir dirs let mbComp = maybe Nothing (\ v -> mbFindDirComponent v comps) mbDir case mbComp of Just x -> return (odir, s{scut_target=x}) Nothing -> - let t = findExeComponent dirs comps (scut_target s) in - if t == (scut_target s) then do + let tExe = findExeComponent dirs comps (scut_target s) in + if tExe == (scut_target s) then do -- couldn't find the component, try locating the file. ls <- getFiles - let ls' = map (\ st@(x,_) -> (x,st)) ls ++ map (\ st@(x,_) -> (baseName x, st)) ls - case lookup t ls' of + let ls' = map (\ st@(x,_) -> (x,st)) ls ++ map (\ st@(x,_) -> (takeFileName x, st)) ls + case lookup tExe ls' of Nothing -> do - ioToIM (putStrLn ("WARNING: unable to locate target " ++ show t)) + ioToIM (putStrLn ("WARNING: unable to locate target " ++ show tExe)) return (featureKey, s) - Just stuff@(f,(fKey,oldCompKey,nm,fSize)) -> do + Just (f,(fKey,oldCompKey,_nm,_fSize)) -> do -- create a new component with keypath that points to target. cId <- newId cName <- newId @@ -663,19 +708,18 @@ -- replaceFile f (fKey, cKey, nm, fSize) return (featureKey, s{scut_target=cKey}) else - return (featureKey, s{scut_target=t}) + return (featureKey, s{scut_target=tExe}) where featureKey = idToKey feat addShortcut :: Key -> (String,Shortcut) -> IM () addShortcut appKey (featureKey,s) = do - i <- newId - let key = idToKey i + sKey <- newId >>= return.idToKey (iKey, idx) <- case (scut_icon s) of Nothing -> return (Nothing, Nothing) Just f -> addIcon f >>= \x -> return (Just (string x), Just (int 0)) - addRow (newShortcut [ "Shortcut" -=> Just (string key) + addRow (newShortcut [ "Shortcut" -=> Just (string sKey) , "Directory_" -=> Just (string appKey) , "Name" -=> Just (string (scut_name s)) , "Component_" -=> Just (string (scut_target s)) @@ -692,11 +736,11 @@ addIcon :: String -> IM Key addIcon icoFile = do i <- newId - let key = take 7 (idToKey i) ++ ".exe" - addRow (newIcon [ "Name" -=> Just (string key) + let iKey = take 7 (idToKey i) ++ ".exe" + addRow (newIcon [ "Name" -=> Just (string iKey) , "Data" -=> Just (file icoFile) ]) - return key + return iKey setCustomTargetDir :: Maybe String -> String -> IM () setCustomTargetDir def pkgName = do @@ -740,6 +784,7 @@ , newInstallUISequence ] +replaceFinishedText :: Maybe String -> IM () replaceFinishedText Nothing = return () replaceFinishedText (Just str) = do replaceRow ( "Control" @@ -764,6 +809,7 @@ , [ "Text" -=> Just ("{\\VSI_MS_Sans_Serif13.0_0_0}" ++ str) -} +addDestText :: IM () addDestText = do addRow (newControl [ "Dialog_" -=> Just (string "SetupTypeDlg") , "Control" -=> Just (string "InstallDirLabel") @@ -803,6 +849,12 @@ where addV (ext, verb, label, args) = addVerb ext verb label args +addExtension :: Id + -> String + -> FilePath + -> String + -> String + -> IM () addExtension feat progId exeFile icoFile ext = do addProgId progId icoFile dirs <- getDirs @@ -816,6 +868,7 @@ , "Feature_" -=> Just (string featureKey) ]) +addVerb :: String -> String -> String -> String -> IM () addVerb ext verb command arg = do addRow (newVerb [ "Extension_" -=> Just (string ext) , "Verb" -=> Just (string verb) @@ -825,6 +878,7 @@ ]) -- given a progID (and its icon), create the ProgId row for it. +addProgId :: String -> String -> IM () addProgId progID icoFile = do rs <- getTableRows "ProgId" let vs = concatMap snd rs @@ -836,15 +890,16 @@ if (not (null ms)) then return () else do - key <- addIcon icoFile + k <- addIcon icoFile addRow (newProgId [ "ProgId" -=> Just (string progID) -- , "ProgId_Parent" -=> Nothing -- , "Class_" -=> Nothing -- , "Description" -=> Nothing - , "Icon_" -=> Just (string key) + , "Icon_" -=> Just (string k) , "IconIndex" -=> Just (int 0) ]) +configureLicense :: Maybe FilePath -> IM () configureLicense Nothing = replaceRow ( "Property" , [ ("Property" -=> "ShowLicenseDlg")] @@ -881,12 +936,15 @@ ], [ ("Text", Just (file f)) ]) +setURL :: String -> IM () +setURL "" = return () setURL url = replaceRow ( "Property" , [ ("Property" -=> "ARPHELPLINK") ] , [ ("Value", Just (string url))] ) +setUserRegistration :: Bool -> IM () setUserRegistration wantIt | wantIt = return () | otherwise = @@ -896,8 +954,8 @@ , [ ("Value", Just (string "0"))] ) - -addBannerBitmap nm Nothing = return () +addBannerBitmap :: String -> Maybe FilePath -> IM () +addBannerBitmap _ Nothing = return () addBannerBitmap nm (Just bmap) = do addBinary nm bmap replaceRow ( "Property" @@ -905,7 +963,8 @@ , [ ("Value", Just (string nm))] ) -addDialogBitmap nm Nothing = return () +addDialogBitmap :: String -> Maybe FilePath -> IM () +addDialogBitmap _ Nothing = return () addDialogBitmap nm (Just bmap) = do addBinary nm bmap replaceRow ( "Property" @@ -913,11 +972,13 @@ , [ ("Value", Just (string nm))] ) +addBinary :: String -> FilePath -> IM () addBinary nm bmap = addRow (newBinary [ "Name" -=> Just (string nm) , "Data" -=> Just (file bmap) ]) +addNestedInstalls :: [(String,Maybe String)] -> IM () addNestedInstalls ss = zipWithM_ addInst ss [0..] where addInst (msiFile, mbOpts) idx = do @@ -938,3 +999,43 @@ [ newAdminExecuteSequence , newInstallExecuteSequence ] + +addAssemblies :: Feature -> [Assembly] -> IM () +addAssemblies feat as = mapM_ (addAssembly feat) as + +addAssembly :: Feature -> Assembly -> IM () +addAssembly bFeat a = do + let featKey = idToKey (fst bFeat) + dirs <- getDirs + comps <- getComponents + let cKey = findExeComponent dirs comps (assem_dll a) + aKey <- maybe (return Nothing) (\ x -> findExeFile x >>= return.Just) (assem_manifest a) + addRow (newMsiAssembly + ([ "Component_" -=> Just (string cKey) + , "Feature_" -=> Just (string featKey) + , "File_Manifest" -=> fmap string aKey + , "File_Application" -=> fmap string (assem_privatePath a) + , "Attributes" -=> if assem_win32 a then Just (int 1) else Just (int 0) + ])) + let + vs_win32 + | not (assem_win32 a) = [ ("ProcessorArchitecture", "MSIL")] + | otherwise = + [ ("Type", "win32") + , ("ProcessorArchitecture", "x86") -- are there any others? ;-) + ] + + vs = + [ ("Name", assem_name a) + , ("Version", assem_version a) + , ("Culture", (\ x -> if null x then "neutral" else x) $ assem_culture a) + , ("PublicKeyToken", assem_publicKey a) + ] ++ vs_win32 + mapM_ (\ (n,v) -> + addRow (newMsiAssemblyName + [ "Component_" -=> Just (string cKey) + , "Name" -=> Just (string n) + , "Value" -=> Just (string v) + ])) + vs + diff --git a/Bamse/PackageUtils.hs b/Bamse/PackageUtils.hs --- a/Bamse/PackageUtils.hs +++ b/Bamse/PackageUtils.hs @@ -16,14 +16,18 @@ import Bamse.Package -import Util.Path ( appendPath, toPlatformPath, fileSuffix ) -import System.Path (isSeparator) +import System.FilePath import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) import System.Environment import Debug.Trace ( trace ) +import Text.Regex +import Data.Char ( isSpace ) +import Data.Maybe +import Data.List + -- | @toMsiFileName fp@ converts a (base) filename to an MSI output -- filename, appending the .msi suffix + doing away with -- troublesome characters. @@ -35,32 +39,32 @@ 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. +lFile dir f = normalise (dir f) -- classifying files according to their extension/suffix: isHiFile :: FilePath -> Bool isHiFile fn = - case fileSuffix fn of - "hi" -> True - _:'_':'h':'i':[] -> True + case takeExtension fn of + ".hi" -> True + '.':_:'_':'h':'i':[] -> True _ -> False isDocFile :: FilePath -> Bool -isDocFile fn = fileSuffix fn `elem` ["html", "pdf", "dvi", "doc", "ps"] +isDocFile fn = takeExtension fn `elem` [".html", ".pdf", ".dvi", ".doc", ".ps"] isHeaderFile :: FilePath -> Bool -isHeaderFile fn = fileSuffix fn `elem` ["h"] +isHeaderFile fn = takeExtension fn `elem` [".h"] dropDirPrefix :: FilePath -> FilePath -> FilePath -dropDirPrefix [] f = dropWhile isSeparator f +dropDirPrefix [] f = dropWhile isPathSep f dropDirPrefix _ [] = [] dropDirPrefix (x:xs) (y:ys) | x == y = dropDirPrefix xs ys - | otherwise = dropWhile isSeparator (y:ys) + | otherwise = dropWhile isPathSep (y:ys) + where +isPathSep :: Char -> Bool +isPathSep c = isPathSeparator c || c == '/' -- to support build-time definitions in strings (via $) addEnvVar :: String -> String -> IO () @@ -151,3 +155,59 @@ where iconDir = lFile bamseDir "icons" +getManifest :: [(String,String)] -> IO (String -> Maybe Bool) +getManifest opts = + case lookup "manifest" opts of + Just fn -> catch (do { ls <- readFile fn ; return (tryMatch (mapMaybe toRegex $ lines ls))}) + (\ _ -> return (const Nothing)) + Nothing -> return (const Nothing) + where + + tryMatch [] _ = Nothing + tryMatch ((flg,x):xs) f = + case matchRegex x f of + Nothing -> tryMatch xs f + Just{} -> Just flg + + toRegex "" = Nothing + toRegex ('#':_) = Nothing + toRegex r + | all isSpace r = Nothing + | otherwise = + -- a single leading '-' indicate that pattern is for exemptions. + case trim r of + ('-':xs) -> Just (False,mkRegex xs) + xs -> Just (True,mkRegex xs) + + trim s = trimR (dropWhile isSpace s) + + trimR xs = maybe "" id $ foldr f Nothing xs + where + f x (Just acc) = Just (x:acc) + f x Nothing + | isSpace x = Nothing + | otherwise = Just [x] + +entryOfInterest :: InstallEnv -> (String -> Maybe Bool) -> FilePath -> Bool +entryOfInterest ienv matcher file + | defaultJunk file = False + | null file' = True + | otherwise = + case maybe True id (matcher file') of + flg + | traceIt -> trace ((if flg then "including" else "excluding") ++ ": " ++ show (file',file)) flg + | otherwise -> flg + where + file' + | topDir `isPrefixOf` file = canonicalize (drop (length topDir) file) + | otherwise = file + + topDir = srcDir ienv + traceIt = isJust (lookup "debug" (userOpts ienv)) + + canonicalize ('\\':xs) = canonicalize xs + canonicalize xs = canon1 xs + + canon1 xs = map (\ x -> if x == '\\' then '/' else x) xs + + defaultJunk f = (last f == '~') || (takeFileName f == ".svn") diff --git a/Bamse/Util/Dir.hs b/Bamse/Util/Dir.hs new file mode 100644 --- /dev/null +++ b/Bamse/Util/Dir.hs @@ -0,0 +1,120 @@ +{- | + Module : Bamse.Util.Dir + Copyright : (c) Sigbjorn Finne, 2002- + + Maintainer : sof@forkIO.com + Stability : + Portability : + + File system directory utilities. +-} +module Bamse.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 ) +import System.FilePath + +-- | 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 (normalise 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 (fpath ) 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 System.FilePath.takeFileName tree) + +isEmpty :: GenDirTree a -> Bool +isEmpty Empty = True +isEmpty _ = False + +isUpDown :: String -> Bool +isUpDown "." = True +isUpDown ".." = True +isUpDown _ = False diff --git a/Bamse/Util/GetOpts.hs b/Bamse/Util/GetOpts.hs new file mode 100644 --- /dev/null +++ b/Bamse/Util/GetOpts.hs @@ -0,0 +1,206 @@ +{- | + + Module : Bamse.Util.GetOpts + Copyright : (c) Sigbjorn Finne, 2004- + + Maintainer : sof@forkIO.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 Bamse.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/Bamse/Util/List.hs b/Bamse/Util/List.hs new file mode 100644 --- /dev/null +++ b/Bamse/Util/List.hs @@ -0,0 +1,96 @@ +{- | + + Module : Bamse.Util.List + Copyright : (c) Sigbjorn Finne, 2001- + + Maintainer : sof@forkIO.com + Stability : + Portability : + + List routines needed by Bamse. +-} +module Bamse.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/Bamse/WindowsInstaller.hs b/Bamse/WindowsInstaller.hs --- a/Bamse/WindowsInstaller.hs +++ b/Bamse/WindowsInstaller.hs @@ -661,8 +661,8 @@ toEnum v = case v of - 0 -> MsiMessageTypeFatalExit 0 -> MsiMessageTypeOk + 0 -> MsiMessageTypeFatalExit 0 -> MsiMessageTypeDefault1 1 -> MsiMessageTypeOkCancel 2 -> MsiMessageTypeAbortRetryIgnore diff --git a/Bamse/Writer.hs b/Bamse/Writer.hs --- a/Bamse/Writer.hs +++ b/Bamse/Writer.hs @@ -41,6 +41,8 @@ -- -> [ReplaceRow] {- rows to replace in the base package -} -- -> IO () , getProductCodes + + , mergePackage ) where import qualified Prelude @@ -52,18 +54,20 @@ import Data.List import Control.Monad -import System ( system, ExitCode(..) ) -import Time ( getClockTime ) +import System.Cmd ( system ) +import System.Exit ( ExitCode(..) ) +import System.Time ( getClockTime ) import Data.Maybe ( fromMaybe, mapMaybe ) -import Directory ( removeFile, doesFileExist ) +import System.Directory ( removeFile, doesFileExist ) import System.IO import Data.Char ( toUpper ) import Data.Int ( Int32 ) import Data.Bits -import Util.List ( mapFirstDefault, enclose ) +import Bamse.Util.List ( mapFirstDefault, enclose ) import System.Win32.Com ( catchComException, throwIOComException ) +import System.Win32.Com.Exception ( Com_Exception ) import System.Win32.Com.Automation ( (#), coRun, coCreateObject, isCoError, coGetErrorString, @@ -134,6 +138,7 @@ revC <- si # getProperty0 (fromIntegral $ fromEnum PID_REVNUMBER) return (prodC, revC) +topHandler :: Installer i -> Com_Exception -> IO a topHandler ip err | isCoError err = flip catchComException throwIOComException $ do let v = coGetErrorString err @@ -165,12 +170,12 @@ map (\ ls@((tnm,sz,_):_) -> (tnm, sz, concatMap (\ (_,_,xs) -> xs) ls)) $ groupBy (\ (t1,_,_) (t2,_,_) -> t1 == t2) ts - toRowData (tnm, rows) = + toRowData (tnm, rows1) = case lookup tnm tables of Just cols -> Just ( tnm , length cols - , map (\ (tnm, vals) -> mapMaybe (toIdx tnm cols) vals) rows + , map (\ (tnm1, vals) -> mapMaybe (toIdx tnm1 cols) vals) rows1 ) Nothing -> trace ("storeTables: WARNING: unknown table " ++ tnm) $ Nothing @@ -183,11 +188,11 @@ show (nm,tabNm)) $ Nothing - addRow rows row@(tn,_) = mapFirstDefault (tn,[row]) (f row) rows + addRow rows1 row@(tn,_) = mapFirstDefault (tn,[row]) (f row) rows1 where - f tab@(tnm,_) (tn,rs2) - | tn == tnm = Just (tnm, tab : rs2) - | otherwise = Nothing + f tab@(tnm,_) (tn2,rs2) + | tn2 == tnm = Just (tnm, tab : rs2) + | otherwise = Nothing -- currently assume that the tables passed -- in aren't 100% complete. (This isn't a good @@ -245,7 +250,8 @@ String s -> rec # setStringData idx s Int i -> rec # setIntegerData idx (fromIntegral i) Long l -> rec # setIntegerData idx (fromIntegral l) - File f -> catchComException + Bamse.MSITable.File f + -> catchComException (rec # setStream idx f) (\ exn -> do hPutStrLn stderr ("Unable to store file: " ++ show f) @@ -325,13 +331,13 @@ -> View b -> (String,String) -> IO () -setPair inst view (name,val) = do +setPair inst view (nm,val) = do rec <- inst # createRecord 2 - rec # setStringData 1 name + rec # setStringData 1 nm rec # setStringData 2 val catchComException (view # execute rec) - (\ e -> putStrLn ("setPair failed: " ++ name) >> throwIOComException e) + (\ e -> putStrLn ("setPair failed: " ++ nm) >> throwIOComException e) return () setSummaryInformation :: [(ProductIDTag, String)] @@ -405,7 +411,7 @@ -- just copy that single file (base.msi) instead. -- createBasePackage :: FilePath -> FilePath -> FilePath -> IO () -createBasePackage bamseDir tDir dest = +createBasePackage _bamseDir tDir dest = copyFile (tDir ++ "\\base.msi") dest {-was: copyFile (src ++ "\\Schema.msi") dest @@ -425,7 +431,7 @@ -> String -> Installer a -> IO () -mergePackage src dest db ip = do +mergePackage src dest _db ip = do db1 <- ip # openDatabase src (fromEnum MsiOpenDatabaseModeTransact) db2 <- ip # openDatabase dest (fromEnum MsiOpenDatabaseModeReadOnly) let errorTable = "_MergeErrors" @@ -515,11 +521,12 @@ -- just ignore return ()) where - setField rec idx (_,Nothing) = return () - setField rec idx (_,Just val) = + setField _rec _idx (_,Nothing) = return () + setField rec idx (_,Just val) = case val of String s -> rec # setStringData idx s - File f -> do + Bamse.MSITable.File f + -> do h <- openFile f ReadMode -- (BinaryMode ReadMode) str <- hGetContents h rec # setStringData idx str @@ -544,6 +551,7 @@ (ioError (userError "no records selected")) return (rec, view) +selectStmt :: String -> [(String,a)] -> [(String,String)] -> String selectStmt tabName vals ls = unwords ([ "SELECT" , unwords fields @@ -555,7 +563,7 @@ fields = intersperse ", " (map (backTick.fst) vals) stuff = intersperse "AND" (map eq ls) - eq (colNm, key) = unwords [backTick colNm, "=", fwdTick key] + eq (colNm, val) = unwords [backTick colNm, "=", fwdTick val] makeCab :: FilePath -> FilePath @@ -578,23 +586,23 @@ when (fromEnum stat /= fromEnum MsiDoActionStatusSuccess) (hPutStrLn stderr "makeCab: CostInitialize failed") -- sequence the File table - view <- db # openView "SELECT Sequence,Attributes FROM File" + fView <- db # openView "SELECT Sequence,Attributes FROM File" catchComException - (view # execute ()) + (fView # execute ()) (\ e -> putStrLn "File selection failed" >> throwIOComException e) let - findSeq lSeq = do - rec <- view # fetch + findSeq theView lSeq = do + rec <- theView # 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_" + seqNo <- rec # getIntegerData 1 + att <- rec # getIntegerData 2 + findSeq theView (if ((att .&. 0x00004000) == 0) && (seqNo > lSeq) then seqNo else lSeq) + lSeq <- findSeq fView 0 + dView <- db # openView "SELECT File,FileName,Directory_,Sequence,File.Attributes FROM File,Component WHERE Component_=Component ORDER BY Directory_" catchComException - (view # execute ()) + (dView # execute ()) (\ e -> putStrLn "Directory selection failed" >> throwIOComException e) let ddfFile = bName ++ ".ddf" hFile <- openFile ddfFile WriteMode @@ -618,11 +626,11 @@ , ".Set Cabinet=ON" ]) let - relabelFiles :: Int32 -> Bool -> [String] -> IO (Int32, Bool, [String]) - relabelFiles lSeq addedFiles msgs = do - rec <- view # fetch + relabelFiles :: View () -> Int32 -> Bool -> [String] -> IO (Int32, Bool, [String]) + relabelFiles theView labSeq addedFiles msgs = do + rec <- theView # fetch if (isNullInterface rec) then - return (lSeq, addedFiles, msgs) + return (labSeq, addedFiles, msgs) else do fKey <- rec # getStringData 1 fName <- rec # getStringData 2 @@ -632,12 +640,12 @@ 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) + if sequ <= labSeq then do + rec # setIntegerData 4 (labSeq + 1) + theView # modify MsiViewModifyUpdate rec + return (labSeq + 1) else - return lSeq + return labSeq let (short,long') = break (=='|') fName let fName' | null short = fName @@ -651,10 +659,10 @@ let sourcePath = sPath ++ fName' hPutStrLn hFile ("\"" ++ sourcePath ++ "\" " ++ fKey) st <- ip # fileAttributes sourcePath - relabelFiles lSeq' True (if st == -1 then (sourcePath : msgs) else msgs) + relabelFiles theView lSeq' True (if st == -1 then (sourcePath : msgs) else msgs) else do - relabelFiles lSeq True msgs - (lSeq, addedFiles, msgs) <- relabelFiles lSeq False [] + relabelFiles theView labSeq True msgs + (lSeq1, addedFiles, msgs) <- relabelFiles dView lSeq False [] hClose hFile when (not (null msgs)) (hPutStrLn stderr ("The following files were not available:" ++ show (unlines msgs))) @@ -669,19 +677,19 @@ ] 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) + mView <- db # openView "SELECT DiskId, LastSequence, Cabinet FROM Media ORDER BY DiskId" + mView # execute () + rec0 <- mView # fetch + (rec2,uMode) <- + if (isNullInterface rec0) then do + rec1 <- ip # createRecord 3 + rec1 # setIntegerData 1 1 + return (rec1, MsiViewModifyInsert) else - return (rec, MsiViewModifyUpdate) - rec # setIntegerData 2 lSeq - rec # setStringData 3 cabName - view # modify uMode rec + return (rec0, MsiViewModifyUpdate) + rec2 # setIntegerData 2 lSeq1 + rec2 # setStringData 3 cabName + mView # modify uMode rec2 sumInfo <- db # getSummaryInformation (3::Int32) n <- now sumInfo # setProperty0 11 n @@ -689,13 +697,14 @@ 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 + sView <- db # openView "SELECT `Name`,`Data` FROM _Streams" + sView # execute () + rec3 <- ip # createRecord 2 + rec3 # setStringData 1 cabFile + rec3 # setStream 2 cabFile + sView # modify MsiViewModifyAssign rec3 return () + -- remove residuals. removeFile "cabber.INF" `catch` (\ _ -> return ()) removeFile "cabber.ddf" `catch` (\ _ -> return ()) diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,16 +1,24 @@ +{-# OPTIONS_GHC -XCPP #-} +-------------------------------------------------------------------- +-- | +-- Module : Bamse.Package +-- Description : Description of an MSI package/product. +-- Copyright : (c) Sigbjorn Finne, 2004-2009 +-- License : BSD3 -- --- (c) 2007, Galois, Inc. +-- Maintainer : Sigbjorn Finne +-- Stability : provisional +-- Portability : portable -- -- 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 @@ -20,15 +28,15 @@ --import HDirectLib as PackageSrc --import ComPkg as PackageSrc --import GaloisPkg as PackageSrc -import Cryptol 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 HsDotnet as PackageSrc --import Base as PackageSrc -{- END_CPP -} main :: IO () main = genBuilder pkg_data @@ -58,7 +66,9 @@ , p_finalMessage = PackageSrc.finalMessage , p_notForAll = PackageSrc.userInstall , p_services = PackageSrc.services - , p_ghcPackage = PackageSrc.ghcPackageInfo +-- , p_ghcPackage = PackageSrc.ghcPackageInfo + , p_cabalPackage = PackageSrc.cabalPackageInfo , p_nestedInstalls = PackageSrc.nestedInstalls + , p_assemblies = PackageSrc.assemblies } diff --git a/System/Path.hs b/System/Path.hs deleted file mode 100644 --- a/System/Path.hs +++ /dev/null @@ -1,45 +0,0 @@ -{- | - - 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 deleted file mode 100644 --- a/Util/Dir.hs +++ /dev/null @@ -1,120 +0,0 @@ -{- | - - 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 deleted file mode 100644 --- a/Util/GetOpts.hs +++ /dev/null @@ -1,206 +0,0 @@ -{- | - - 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 deleted file mode 100644 --- a/Util/List.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Util/Path.hs +++ /dev/null @@ -1,256 +0,0 @@ -{- | - - 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/bamse.cabal b/bamse.cabal --- a/bamse.cabal +++ b/bamse.cabal @@ -1,18 +1,33 @@ name: bamse -version: 0.9.3 +version: 0.9.4 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. - + of features to put together MSIs using Haskell. + . + Bamse lets you author /installer generators/, i.e., applications + that will generate Windows Installers when invoked (and pointed + at the files and other resources to include for that particular + installer instance.) Bamse is also accessible as a library, letting + you integrate MSI creation into your codebase. + . + The package has a number of example /templates/ showing how to + specify a generator; /real/ examples that have been used to ship + software by a number of projects and companies. See the @templates/@ + directory; one good way to get started is to modify one of these + to suit the needs of the installers you are looking to create. + . + For a worked example of how to build installers from your Cabal packages, + and possibly automatically install them when running the MSI, see @examples/Cabal.hs@ + (and the README in that directory.) category : System license : BSD3 license-file : LICENSE author : Sigbjorn Finne maintainer : sof@forkIO.com cabal-version : >= 1.2 -build-type : Simple +build-type : Custom extra-source-files: README license.rtf icons/folder.exe @@ -53,6 +68,8 @@ tools/msiIcon.c tools/README.txt tools/Makefile + tools/Wrapper.hs + tools/custWrap.exe templates/Alex.hs templates/Bamse.hs templates/Base.hs @@ -64,15 +81,35 @@ templates/HDirectLib.hs templates/Haddock.hs templates/Happy.hs + templates/HsDotnet.hs templates/Hugs98.hs templates/Hugs98Net.hs templates/PubCryptol.hs templates/SOE.hs + examples/Cabal.hs + examples/README + tests/Tests.hs flag old-base description: Old, monolithic base default: False +flag build-tests + default: False + +-- +-- To use bamseGen, configure as follows, e.g., +-- +-- Setup configure -fbamseGen --ghc-options=-DPACKAGE=Alex +-- +flag bamseGen + description: Build parameterized installer generator (via PACKAGE define) + default: False + +flag hsdotnet + description: Build HsDotnet installer generator + default: True + library { Exposed-modules: Bamse.Builder, Bamse.DiaWriter, @@ -89,23 +126,47 @@ Bamse.WindowsInstaller, Bamse.Writer - Other-Modules: System.Path, - Util.Dir, - Util.GetOpts, - Util.List, - Util.Path + Other-Modules: Bamse.Util.Dir, + Bamse.Util.GetOpts, + Bamse.Util.List Ghc-Options: -Wall - build-depends: com >= 1.2.2 , haskell98, directory, pretty + build-depends: com >= 1.2.3 , process, directory, pretty, regex-compat, old-time, filepath if flag(old-base) Build-Depends: base < 3 else Build-Depends: base >= 4 } -executable bamse { +executable hsDotnetGen { main-is: Main.hs + CPP-Options: -DPACKAGE=HsDotnet hs-source-dirs: . templates ghc-options: -Wall + if flag(hsdotnet) && !flag(bamseGen) + Buildable: True + else + Buildable: False +} + +executable bamseGen { + main-is: Main.hs +-- CPP-Options: -DPACKAGE=flag(Package) + hs-source-dirs: . templates + ghc-options: -Wall -idist/build + if flag(bamseGen) + Buildable: True + else + Buildable: False +} + +executable runTests { + if flag(build-tests) + buildable: True + else + buildable: False + Main-Is: tests/Tests.hs + build-depends: QuickCheck, HUnit + Hs-Source-Dirs: ., tests } diff --git a/examples/Cabal.hs b/examples/Cabal.hs new file mode 100644 --- /dev/null +++ b/examples/Cabal.hs @@ -0,0 +1,150 @@ +{- | + Module : Cabal + Description : Building an installer from your Cabal project. + Copyright : (c) Sigbjorn Finne, 2009 + License : BSD3 + + Generating an MSI installer from your Cabal-built Haskell library or + application. + + This is an example of how to take the contents of your Cabal + project and box it up in Windows + Installer form. Along with details specifying the properties + of your package (name, author, project web site etc.) you also + list the files you want to include. Given those two pieces, the + Bamse builder goes to work, outputting in the end a working MSI + that's ready for distribution. +-} +module Main where + +import Bamse.Package +import Bamse.PackageUtils ( dropDirPrefix ) +import Bamse.Builder +import Data.List ( isPrefixOf ) +import System.FilePath + +--import Debug.Trace + +-- | @main@ kicks off the party. To see what command-line options +-- it supports, invoke it with @--help@. +-- +-- Typical invocation: +-- +-- > foo$ genCabal --generate-guids -o myInstaller.msi c:/path/to/the/top/of/my/cabal/pkg +-- > # if you want to re-generate the MSI (but not update its product etc. GUIDs.) +-- > foo$ genCabal -u -o myInstaller.msi c:/path/to/the/top/of/my/cabal/pkg +main :: IO () +main = do + genBuilder pkgCabal + -- alternatively, supply the command-line arguments directly: + -- (this is something you want to do when integrating the Bamse library + -- into your application directly.) + -- genBuilderArgs pkgCabal ["--generate-guids", "-o", "c:/public/deploy/myInst.msi"] + +-- | @pkgCabal@ is the toplevel 'Bamse.Package.PackageData' value, containing +-- all the interesting bits of info that make up an MSI (as seen/supported by Bamse..) +-- We /derive/ it from 'Bamse.Package.minimalPackageData', which supplies default +-- values for most MSI package properties. Here we simply override with the portions +-- relevant to our Cabal example. For more comprehensive and demanding installers, +-- please consult 'Bamse.Package.PackageData' or see the @templates/@ directory for +-- live examples of other installer specifications. +pkgCabal :: PackageData +pkgCabal = minimalPackageData + { p_fileMap = dirTree + , p_defOutFile = defaultOutputFile + , p_pkgInfo = cabalPkgInfo + , p_webSite = webSite + , p_baseFeature = baseFeature + , p_desktopShortcuts = \ _ienv -> [] + -- Note: this needs to be a .rtf file holding your license. If you + -- supply one (after having generated the RTF via wordpad or some such..), + -- the installer will include in its UI a user-agreement form displaying + -- the license text. + , p_license = \ _ -> Nothing + -- Somewhat confusing perhaps, but this field is used to control the + -- on-install running of Cabal itself, letting you automatically install + -- (and possibly) the Cabal package at install-time. (The user is given + -- a choice whether or not to do this in the UI.) We want to do this, + -- but only allow the @install@ step; no support for building from source. + , p_cabalPackage = Just cabalPackage + } + +-- +-- The rest of this module supplies the definitions of the fields that we +-- filled in for @pkgCabal' + +-- +-- First, some overall package information: +-- +pkgName :: String +pkgName = "MyPackage" + +pkgVersion :: String +pkgVersion = "1.2.0" -- major.minor.build[.whatever] + +pkgAuthor :: String +pkgAuthor = "Kap. Abel" + +cabalPkgInfo :: Package +cabalPkgInfo = + Package { name = pkgName + , title = pkgName -- will show up in UI. + , productVersion = pkgVersion + , author = pkgAuthor + , comment = "This is an example package" + } + +-- | @dirTree@ is the function that walks over the directory +-- you point the MSI generator at when running, returning the +-- files and directories to include in the generated MSI. +-- +-- This particular one will include anything inside the build @dist/@ +-- directory + the .cabal, LICENSE and Setup.hs files. We +-- don't consider including the sources here, but doing so +-- is an easy extension (see @templates/@ for examples of this.) +-- +dirTree :: InstallEnv -> IO DirTree +dirTree ienv = findFiles ofInterest topDir + where + topDir = srcDir ienv + ofInterest f = {-trace (show (f_local,res)) -}res + + where + f_local = dropDirPrefix topDir f + res = + null f_local || + "dist" `isPrefixOf` f_local || + takeExtension f_local == ".cabal" || + f_local `elem` package_files + + package_files = ["Setup.hs", "LICENSE", "README", "custWrap.exe"] + +-- | Extra Cabal specific information used to direct installation +-- of the package on the user's machine. +cabalPackage :: CabalPackage +cabalPackage = CabalPackage + { cabal_packageName = name cabalPkgInfo + , cabal_forGhcVersion = "6.10.1" + , cabal_packageFile = Just (name cabalPkgInfo ++ ".cabal") + , cabal_pkgCmdLine = Nothing + , cabal_fromSource = False -- don't support from source building via the MSI. + } + +-- | When invoked the MSI generator can emit the MSI into a default output file. +-- (the @-o@ option is what you would normally use to override this.) +defaultOutputFile :: FilePath +defaultOutputFile = name cabalPkgInfo ++ '-':map subst (productVersion cabalPkgInfo) ++ ".msi" + where + subst '.' = '-' + subst ch = ch + +-- | @webSite@ contains the URL for the package itself. +-- If that doesn't apply to you, its Hackage URL would be good. +webSite :: {-URL-}String +webSite = "http://www.haskell.org/cabal" + +-- | @baseFeature@ is a mostly-internal name, but you need to supply +-- a name. Defaults to @cabalPkgInfo.name@ +baseFeature :: Feature +baseFeature = (name cabalPkgInfo, name cabalPkgInfo ++ " package for GHC") + diff --git a/examples/README b/examples/README new file mode 100644 --- /dev/null +++ b/examples/README @@ -0,0 +1,20 @@ +Examples: currently only a worked-through example of how +to bundle up your Cabal project in an MSI. + +To build and invoke it, do: + + foo$ cd /to/my/bamse/directory + # Skip building the Bamse package if you already have.. + foo$ runghc Setup configure --user; runghc Setup build; runghc Setup install + foo$ cd examples + foo$ ghc -o genCabal Cabal.hs -package bamse + # Edit the Cabal.hs sources to have it fit your application/package (name, author, files, etc.) + foo$ cd /to/my/cabal/package + foo$ cp /to/my/bamse/directory/examples/genCabal.exe . + foo$ ./genCabal --generate-guids -o myMSI.msi --tool-dir=c:/to/my/bamse/directory . + ... + foo$ cp myMSI.msi c:/public/publish/directory/ + # Uh, you may want to test it some first ;-) + + + diff --git a/templates/Alex.hs b/templates/Alex.hs --- a/templates/Alex.hs +++ b/templates/Alex.hs @@ -19,23 +19,24 @@ import Data.List -import Util.Dir -import Util.Path -import Util.List +import Bamse.Util.Dir +import System.FilePath import Bamse.Package import Bamse.PackageUtils +pkgName, pkgVersion, pkgDoc :: String pkgName = "alex" -pkgVersion = "2.01" -pkgDoc = "doc\\alex\\alex.html" +pkgVersion = "2.3.1" +pkgDoc = "doc\\alex-"++pkgVersion++"\\index.html" +defaultOutFile :: FilePath defaultOutFile = toMsiFileName pkgName pkg :: Package pkg = Package { name = pkgName , title = pkgName - , productVersion = "2.0.1.0" + , productVersion = "2.3.1.0" , author = "Simon Marlow" , comment = unwords [pkgName, "Version", pkgVersion] } @@ -104,7 +105,7 @@ dirTree ienv = findFiles ofInterest (srcDir ienv) where ofInterest file = not (last file == '~') && - not (baseName file == "CVS") + not (takeFileName file == "CVS") distFileMap :: Maybe (FilePath -> Maybe FilePath) distFileMap = Nothing @@ -134,4 +135,12 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Nothing + +nestedInstalls :: [(FilePath, Maybe String)] nestedInstalls = [] + +assemblies :: [Assembly] +assemblies = [] + diff --git a/templates/Bamse.hs b/templates/Bamse.hs --- a/templates/Bamse.hs +++ b/templates/Bamse.hs @@ -20,14 +20,16 @@ import Bamse.Package import Bamse.PackageUtils -import Util.Dir ( DirTree(..), findFiles ) -import Util.Path ( baseName, dirname, fileSuffix ) +import Bamse.Util.Dir ( DirTree, findFiles ) import Debug.Trace +import System.FilePath +pkgName, pkgVersion :: String pkgName = "bamse" -pkgVersion = "1.0" +pkgVersion = "1.2" -- what to output the MSI as if no -o option is given. +defaultOutFile :: FilePath defaultOutFile = toMsiFileName (pkgName ++ '-':pkgVersion) -- 'information summary stream' data bundled up together. @@ -92,10 +94,10 @@ iconDir = lFile (toolDir ienv) "icons" desktopShortcuts :: InstallEnv -> [Shortcut] -desktopShortcuts ienv = [] +desktopShortcuts _ienv = [] extensions :: InstallEnv -> [ Extension ] -extensions ienv = [] +extensions _ienv = [] verbs :: [ ( String -- extension , String -- verb @@ -120,21 +122,21 @@ ofInterest' f = if ofInterest f then trace ("including:" ++ f) True - else trace ("excluding:" ++ f ++ show (dirname f)) False + else trace ("excluding:" ++ f ++ show (takeDirectory f)) False - ofInterest file = {-trace ("considering: " ++ show (dirname fileRel, fileRel)) $ -} not $ + ofInterest file = {-trace ("considering: " ++ show (takeDirectory 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"] + (takeDirectory fileRel == "" && takeExtension fileRel == ".log") || + (takeDirectory fileRel == "" && takeExtension fileRel == ".msi") || + (takeDirectory fileRel == "" && takeExtension fileRel == ".exe") || + (takeDirectory fileRel == "" && takeExtension fileRel == ".a") || + takeExtension fileRel `elem` [".o", ".obj", ".hi"] where fileRel = dropDirPrefix (srcDir ienv) file emacsCVSMeta f = - case baseName f of + case takeFileName f of '#':_ -> True '.':'#':_ -> True "CVS" -> True @@ -177,3 +179,9 @@ , ("galois.msi", Nothing) ] -} + +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Nothing + +assemblies :: [Assembly] +assemblies = [] diff --git a/templates/Base.hs b/templates/Base.hs --- a/templates/Base.hs +++ b/templates/Base.hs @@ -41,14 +41,18 @@ , services -- :: [Service] , ghcPackageInfo -- :: Maybe GhcPackage , nestedInstalls -- :: [(String, Maybe String)] + , cabalPackageInfo + , assemblies ) where import Bamse.Package import Bamse.PackageUtils -import Util.Dir ( DirTree, GenDirTree(..) ) +import Bamse.Util.Dir ( DirTree, GenDirTree(..) ) +appName :: String appName = "myapp" +defaultOutFile :: FilePath defaultOutFile = toMsiFileName appName pkg :: Package @@ -85,10 +89,10 @@ startMenu _ienv = (baseFeatureName, []) desktopShortcuts :: InstallEnv -> [Shortcut] -desktopShortcuts ienv = [] +desktopShortcuts _ienv = [] extensions :: InstallEnv -> [ Extension ] -extensions ienv = [ ] +extensions _ienv = [ ] verbs :: [ ( String -- extension , String -- verb @@ -108,7 +112,7 @@ featureMap = Nothing license :: InstallEnv -> Maybe FilePath -license ienv = Nothing +license _ienv = Nothing userRegistration :: Bool userRegistration = False @@ -128,4 +132,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Nothing + +nestedInstalls :: [a] nestedInstalls = [] + +assemblies :: [Assembly] +assemblies = [] diff --git a/templates/ComPkg.hs b/templates/ComPkg.hs --- a/templates/ComPkg.hs +++ b/templates/ComPkg.hs @@ -17,15 +17,21 @@ -------------------------------------------------------------------- module ComPkg where -import Util.Dir -import Util.Path +import Bamse.Util.Dir +import System.FilePath import Bamse.Package import Bamse.PackageUtils import Debug.Trace +versionNumber :: String versionNumber = "0.30" +libVersion :: String libVersion = "comlib-" ++ versionNumber + +defaultOutFile :: FilePath defaultOutFile = toMsiFileName libVersion + +packageName :: String packageName="comLib" pkg :: Package @@ -94,23 +100,23 @@ ofInterest' f = if ofInterest f then trace ("including:" ++ f) True - else trace ("excluding:" ++ f ++ show (dirname f)) False + else trace ("excluding:" ++ f ++ show (takeDirectory 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"]) + || takeFileName path `elem` ["com.pkg", "HScom.o", "doc", "include", "cbits"] + || takeFileName path == "doc" || takeFileName (takeDirectory path) == "doc" + || takeFileName path == "build" || takeFileName (takeDirectory path) == "build" + || takeExtension path `elem` [{-"",-} ".a", ".hi", ".h", ".hs"] + || not (emacsCVSMeta path || takeExtension 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"]) +-- (takeExtension file `elem` [""{-directory-}, ".dll", ".hs", ".lhs", ".idl", ".h", ".pkg"]) emacsCVSMeta f = - case baseName f of + case takeFileName f of '#':_ -> True '.':'#':_ -> True "CVS" -> True @@ -162,4 +168,12 @@ def s v = '-':'D':s ++ '=':tgt v +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = [] + + +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Nothing + +assemblies :: [Assembly] +assemblies = [] diff --git a/templates/Cryptol.hs b/templates/Cryptol.hs --- a/templates/Cryptol.hs +++ b/templates/Cryptol.hs @@ -20,14 +20,16 @@ import Bamse.Package import Bamse.PackageUtils -import Util.Dir ( DirTree(..), findFiles ) -import Util.Path ( baseName ) -import Util.List ( concatWith ) +import Bamse.Util.Dir ( DirTree, findFiles ) +import Bamse.Util.List ( concatWith ) +import System.FilePath +pkgName, pkgVersion :: String pkgName = "Cryptol" pkgVersion = expandString "$" -- what to output the MSI as if no -o option is given. +defaultOutFile :: FilePath defaultOutFile = toMsiFileName (pkgName ++ '-':pkgVersion) -- 'information summary stream' data bundled up together. @@ -80,6 +82,7 @@ sepBy ch ls = concatWith ch ls tgt = ("[TARGETDIR]"++) +cryptolSettings :: [RegEntry] cryptolSettings = -- ToDo: have the interpreter create these entries on-the-fly, if missing. -- => drop these entries. @@ -141,14 +144,14 @@ ] cryptolExtension :: FilePath -> FilePath -> String -> Extension -cryptolExtension topDir toolDir ext +cryptolExtension topDir tDir ext = ( "CryptolFile" , lFile topDir "cryptol.exe" , lFile iconDir "cry.exe" , ext ) where - iconDir = lFile toolDir "icons" + iconDir = lFile tDir "icons" verbs :: [ ( String -- extension , String -- verb @@ -176,8 +179,8 @@ dirTree ienv = findFiles ofInterest (srcDir ienv) where ofInterest file = not (last file == '~') && - not (baseName file == "CVS") && - not (baseName file == "bin") + not (takeFileName file == "CVS") && + not (takeFileName file == "bin") {- Older experiment in specifying a dist tree which differed from the source tree. Keep around as it might prove useful @@ -263,4 +266,12 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Nothing + +nestedInstalls :: [(FilePath, Maybe String)] nestedInstalls = [] + +assemblies :: [Assembly] +assemblies = [] + diff --git a/templates/GHC.hs b/templates/GHC.hs --- a/templates/GHC.hs +++ b/templates/GHC.hs @@ -21,19 +21,26 @@ -------------------------------------------------------------------- module GHC where -import Util.Dir -import Util.Path +import Bamse.Util.Dir import Bamse.Package import Bamse.PackageUtils +import System.FilePath -- Start section of version-specific settings: +versionNumber :: String versionNumber = "6.6.1" + +versionStringUser :: String versionStringUser = "version " ++ versionNumber +buildNumber :: String buildNumber = "0" + +ghcVersion :: String ghcVersion = "ghc-" ++ versionNumber -- End section -- default name of output file; used if no -o option is provided. +defaultOutFile :: FilePath defaultOutFile = toMsiFileName ghcVersion -- @@ -140,7 +147,7 @@ dirTree ienv = findFiles ofInterest (srcDir ienv) where ofInterest file = not (not (null (tail file)) && last file == '~') && - not (baseName file == "CVS") + not (takeFileName file == "CVS") distFileMap :: Maybe (FilePath -> Maybe FilePath) distFileMap = Nothing @@ -171,4 +178,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = [] + +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Nothing + +assemblies :: [Assembly] +assemblies = [] diff --git a/templates/GaloisPkg.hs b/templates/GaloisPkg.hs --- a/templates/GaloisPkg.hs +++ b/templates/GaloisPkg.hs @@ -17,17 +17,21 @@ -------------------------------------------------------------------- module GaloisPkg where -import Util.Dir -import Util.Path +import Bamse.Util.Dir +import System.FilePath import Bamse.Package import Bamse.PackageUtils -import Debug.Trace import Data.Maybe ( fromJust ) +versionNumber :: String versionNumber = "0.10" +libName :: String libName="galois" + +libVersion :: String libVersion = "galois-" ++ versionNumber +defaultOutFile :: FilePath defaultOutFile = toMsiFileName libVersion pkg :: Package @@ -79,10 +83,10 @@ iconDir = toolDir ienv ++ "\\icons" desktopShortcuts :: InstallEnv -> [Shortcut] -desktopShortcuts ienv = [] +desktopShortcuts _ienv = [] extensions :: InstallEnv -> [ Extension ] -extensions ienv = [ ] +extensions _ienv = [ ] verbs :: [ ( String -- extension , String -- verb @@ -96,33 +100,35 @@ dirTree ienv = findFiles ofInterest (srcDir ienv) where -- Note: 'path' is prefixed by 'topDir'. - ofInterest path = True + 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"] + || takeFileName path `elem` ["com.pkg", "HScom.o", "doc", "imports", "include"] + || takeFileName path == "doc" || takeFileName (takeDirectory path) == "doc" + || takeExtension 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"]) +-- (takeExtension 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. + | otherwise = takeFileName fn -- and everything else in the toplevel directory. +-} featureMap :: Maybe (FilePath -> FeatureName) featureMap = Nothing license :: InstallEnv -> Maybe FilePath -license ienv = Nothing +license _ienv = Nothing userRegistration :: Bool userRegistration = False @@ -155,5 +161,11 @@ def s v = '-':'D':s ++ '=':tgt v +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = [] +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Nothing + +assemblies :: [Assembly] +assemblies = [] diff --git a/templates/Greencard.hs b/templates/Greencard.hs --- a/templates/Greencard.hs +++ b/templates/Greencard.hs @@ -17,14 +17,19 @@ -------------------------------------------------------------------- module Greencard where -import Util.Dir -import Util.Path +import Bamse.Util.Dir import Bamse.Package import Bamse.PackageUtils -gcVersion = "gc-2.05" +import System.FilePath + +gcVersion :: String +gcVersion = "gc-"++versionNumber + +versionNumber :: String versionNumber = "2.05" +defaultOutFile :: FilePath defaultOutFile = toMsiFileName gcVersion pkg :: Package @@ -99,15 +104,15 @@ 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")) + not (takeFileName file == gcVersion) && + not (takeFileName file == "green-card.junk") && + not (takeFileName file == "distrib") && + not (takeFileName file == "CVS") && + not (takeFileName file == "mk") && + (not (takeExtension file == ".o") || + (takeFileName file == "HSgreencard.o")) && + (not (takeExtension file == ".hi") || + (takeFileName file == "StdDIS.hi")) distFileMap :: Maybe (FilePath -> Maybe FilePath) distFileMap = Nothing @@ -136,4 +141,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = [] + +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Nothing + +assemblies :: [Assembly] +assemblies = [] diff --git a/templates/HDirectLib.hs b/templates/HDirectLib.hs --- a/templates/HDirectLib.hs +++ b/templates/HDirectLib.hs @@ -17,14 +17,18 @@ -------------------------------------------------------------------- module HDirectLib where -import Util.Dir -import Util.Path +import Bamse.Util.Dir +import System.FilePath import Bamse.Package import Bamse.PackageUtils +libVersion :: String libVersion = "hdirect-lib-0.19-hugsDec2001" + +versionNumber :: String versionNumber = "0.19" +defaultOutFile :: FilePath defaultOutFile = toMsiFileName libVersion pkg :: Package @@ -80,7 +84,7 @@ where -- Note: the file is also the name of the directory ofInterest file = - (fileSuffix file `elem` [""{-directory-}, "dll", "hs", "lhs", "idl", "h"]) + (takeExtension file `elem` [""{-directory-}, ".dll", ".hs", ".lhs", ".idl", ".h"]) distFileMap :: Maybe (FilePath -> Maybe FilePath) distFileMap = Nothing @@ -109,4 +113,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = [] + +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Nothing + +assemblies :: [Assembly] +assemblies = [] diff --git a/templates/Haddock.hs b/templates/Haddock.hs --- a/templates/Haddock.hs +++ b/templates/Haddock.hs @@ -18,17 +18,19 @@ module Haddock where import Data.List +import System.FilePath -import Util.Dir -import Util.Path -import Util.List +import Bamse.Util.Dir import Bamse.Package import Bamse.PackageUtils + +pkgName, pkgVersion, pkgDoc :: String pkgName = "haddock" pkgVersion = "0.7" pkgDoc = "doc\\haddock\\haddock.html" +defaultOutFile :: FilePath defaultOutFile = toMsiFileName pkgName pkg :: Package @@ -104,7 +106,7 @@ dirTree ienv = findFiles ofInterest (srcDir ienv) where ofInterest file = not (last file == '~') && - not (baseName file == "CVS") + not (takeFileName file == "CVS") distFileMap :: Maybe (FilePath -> Maybe FilePath) distFileMap = Nothing @@ -134,4 +136,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = [] + +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Nothing + +assemblies :: [Assembly] +assemblies = [] diff --git a/templates/Happy.hs b/templates/Happy.hs --- a/templates/Happy.hs +++ b/templates/Happy.hs @@ -19,23 +19,26 @@ import Data.List -import Util.Dir -import Util.Path -import Util.List +import Bamse.Util.Dir +import System.FilePath import Bamse.Package import Bamse.PackageUtils +pkgName :: String pkgName = "happy" -pkgVersion = "1.15" -pkgDoc = "doc\\happy\\index.html" +pkgVersion :: String +pkgVersion = "1.18.3" +pkgDoc :: String +pkgDoc = "doc\\happy-"++pkgVersion++"\\index.html" +defaultOutFile :: FilePath defaultOutFile = toMsiFileName pkgName pkg :: Package pkg = Package { name = pkgName , title = pkgName - , productVersion = "1.1.5.0" + , productVersion = "1.18.3.0" , author = "Simon Marlow" , comment = unwords [pkgName, "Version", pkgVersion] } @@ -104,8 +107,8 @@ dirTree ienv = findFiles ofInterest (srcDir ienv) where ofInterest file = not (last file == '~') && - not (baseName file == "CVS") - + not (takeFileName file == "CVS") + distFileMap :: Maybe (FilePath -> Maybe FilePath) distFileMap = Nothing @@ -134,4 +137,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Nothing + +nestedInstalls :: [(FilePath, Maybe String)] nestedInstalls = [] + +assemblies :: [Assembly] +assemblies = [] diff --git a/templates/HsDotnet.hs b/templates/HsDotnet.hs new file mode 100644 --- /dev/null +++ b/templates/HsDotnet.hs @@ -0,0 +1,175 @@ +-------------------------------------------------------------------- +-- | +-- Module : HsDotnet +-- Description : Specification/template for the hs-dotnet package. +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer : Sigbjorn Finne +-- Stability : provisional +-- Portability : portable +-- +-- 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 HsDotnet where + +import Bamse.Package +import Bamse.PackageUtils + +versionNumber :: String +versionNumber = "0.40" + +libVersion :: String +libVersion = "hs-dotnet-" ++ versionNumber + +defaultOutFile :: FilePath +defaultOutFile = toMsiFileName libVersion + +packageName :: String +packageName="hs-dotnet" + +pkg :: Package +pkg = Package + { name = "hs-dotnet" + , title = "Haskell .NET interop framework" + , productVersion = "1.0.4.0" + , author = "Sigbjorn Finne" + , comment = "Version: " ++ versionNumber + } + +webSite :: String +webSite = "http://haskell.forkio.com/hs-dotnet" + +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 = "hsdotnet" + +baseFeature :: Feature +baseFeature = (baseFeatureName, "hs-dotnet package for GHC") + +startMenu :: InstallEnv -> (String, [Shortcut]) +startMenu ienv = ("Haskell/"++packageName, entries) + where + entries :: [Shortcut] + entries = + [ Shortcut "Documentation (HTML)" + (lFile (srcDir ienv) "dist\\doc\\html\\hs-dotnet\\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 = do + mf <- getManifest (userOpts ienv) + findFiles (entryOfInterest ienv mf) topDir + where + topDir = srcDir ienv + +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.10.1" + +finalMessage :: Maybe String +finalMessage = Nothing + +userInstall :: Bool +userInstall = False + +services :: [Service] +services = [] + +nestedInstalls :: [a] +nestedInstalls = [] + +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Just $ + CabalPackage { cabal_packageName = "hs-dotnet" + -- ToDo: allow 'most-recent' compiler to be used. + , cabal_forGhcVersion = forGhcVersion + , cabal_packageFile = Just "hs-dotnet.cabal" + , cabal_pkgCmdLine = Nothing + , cabal_fromSource = True + } + +assemblies :: [Assembly] +assemblies = [ bridge_assembly ] + +-- don't like the duplication of information here (version magic number in installer, bridge and package..!) +-- Ditto for the public key..absolutely mental. +bridge_assembly :: Assembly +bridge_assembly = + emptyAssembly + { assem_dll = "HsDotnetBridge.dll" + , assem_name = "HsDotnetBridge" + , assem_manifest = Just "HsDotnetBridge.dll" + , assem_version = "0.4.0.0" + , assem_publicKey = "31b6626774fafd8b" + , assem_win32 = False -- the default, but still. + } + +--- unused stuff until the end: + +{- OLD and incomplete support for GHC .pkgs: +ghcPackageInfo :: Maybe GhcPackage +ghcPackageInfo = Just $ + GhcPackage { ghc_packageName = "hs-dotnet" + -- ToDo: allow 'most-recent' compiler to be used. + , ghc_forVersion = forGhcVersion + , ghc_packageFile = Just "hs-dotnet.cabal" + , ghc_pkgCmdLine = Just (unwords [ "Setup", "install" ]) + } + where + tgt "" = "\"[TARGETDIR]build\"" + tgt s = "\"[TARGETDIR]" ++ s ++ "\"" + + def s v = '-':'D':s ++ '=':tgt v +-} + diff --git a/templates/Hugs98.hs b/templates/Hugs98.hs --- a/templates/Hugs98.hs +++ b/templates/Hugs98.hs @@ -19,12 +19,14 @@ import Bamse.Package import Bamse.PackageUtils -import Util.Dir -import Util.Path +import Bamse.Util.Dir +import System.FilePath +hugsVersion, versionString :: String hugsVersion = "Nov 2003" versionString = "Nov2003" +defaultOutFile :: String defaultOutFile = toMsiFileName "hugs98-Nov2003" pkg :: Package @@ -193,7 +195,7 @@ ofInterest file = not (ignoreDir file) && not (last file == '~') && - not (baseName file == "CVS") + not (takeFileName file == "CVS") ignoreDir file = file `elem` ignore_dirs @@ -232,4 +234,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = [] + +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Nothing + +assemblies :: [Assembly] +assemblies = [] diff --git a/templates/Hugs98Net.hs b/templates/Hugs98Net.hs --- a/templates/Hugs98Net.hs +++ b/templates/Hugs98Net.hs @@ -21,12 +21,16 @@ import Bamse.Package import Bamse.PackageUtils -import Util.Dir -import Util.Path +import Bamse.Util.Dir +import System.FilePath +versionNumber :: String versionNumber = "March2003" +defaultOutFile :: FilePath defaultOutFile = "hugs98-net-March2003.msi" + +packageDir :: String packageDir = "hugs98-net" @@ -125,7 +129,7 @@ file /= topDir ++ "\\demos" && file /= topDir ++ "\\tools" && not (last file == '~') && - not (baseName file == "CVS") + not (takeFileName file == "CVS") distFileMap :: Maybe (FilePath -> Maybe FilePath) distFileMap = Nothing @@ -154,4 +158,13 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing + +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = [] + +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Nothing + +assemblies :: [Assembly] +assemblies = [] + diff --git a/templates/PubCryptol.hs b/templates/PubCryptol.hs --- a/templates/PubCryptol.hs +++ b/templates/PubCryptol.hs @@ -22,15 +22,17 @@ import Bamse.Package import Bamse.PackageUtils -import Data.List ( intersperse ) -import Util.Dir ( DirTree(..), findFiles ) -import Util.Path ( baseName ) -import Util.List ( concatWith ) +import Bamse.Util.Dir ( DirTree, findFiles ) +import Bamse.Util.List ( concatWith ) +import System.FilePath +pkgName :: String pkgName = "Cryptol" +pkgVersion :: String pkgVersion = "0.1" -- expandString "$" -- what to output the MSI as if no -o option is given. +defaultOutFile :: FilePath defaultOutFile = toMsiFileName (pkgName ++ '-':pkgVersion) -- 'information summary stream' data bundled up together. @@ -83,6 +85,7 @@ sepBy ch ls = concatWith ch ls tgt = ("[TARGETDIR]"++) +cryptolSettings :: [RegEntry] cryptolSettings = -- ToDo: have the interpreter create these entries on-the-fly, if missing. -- => drop these entries. @@ -134,14 +137,14 @@ ] cryptolExtension :: FilePath -> FilePath -> String -> Extension -cryptolExtension topDir toolDir ext +cryptolExtension topDir tDir ext = ( "CryptolFile" , lFile topDir "cryptol.exe" , lFile iconDir "cry.exe" , ext ) where - iconDir = lFile toolDir "icons" + iconDir = lFile tDir "icons" verbs :: [ ( String -- extension , String -- verb @@ -169,8 +172,8 @@ dirTree ienv = findFiles ofInterest (srcDir ienv) where ofInterest file = not (last file == '~') && - not (baseName file == "CVS") && - not (baseName file == "bin") + not (takeFileName file == "CVS") && + not (takeFileName file == "bin") {- Older experiment in specifying a dist tree which differed from the source tree. Keep around as it might prove useful @@ -226,7 +229,7 @@ topDir = srcDir ++ "\\cryptol" ofInterest file = let - base = baseName file + base = takeFileName file suf = fileSuffix file in not (last file `elem` "~#") && not (base == "CVS") && @@ -256,4 +259,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = [] + +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Nothing + +assemblies :: [Assembly] +assemblies = [] diff --git a/templates/SOE.hs b/templates/SOE.hs --- a/templates/SOE.hs +++ b/templates/SOE.hs @@ -19,12 +19,12 @@ -------------------------------------------------------------------- module SOE where -import MSIExtra -import Util.Dir -import Package +import Bamse.Util.Dir +import Bamse.Package +import Bamse.PackageUtils +defaultOutFile :: FilePath defaultOutFile = "SOE.msi" -srcDir = "c:\\src" pkg :: Package pkg = Package @@ -33,64 +33,50 @@ , 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" +bannerBitmap :: InstallEnv -> Maybe FilePath +bannerBitmap ienv = Just (lFile (toolDir ienv) "soe/banner.bmp") +bgroundBitmap :: InstallEnv -> Maybe FilePath +bgroundBitmap ienv = Just (lFile (toolDir ienv) "art/bground2.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 ] +features :: [Tree Feature] +features = [ Leaf baseFeature ] -baseFeature :: (String, String) +baseFeature :: Feature baseFeature = ("SOE", "School of Expression") -startMenu :: (String, [Shortcut]) -startMenu = ("School of Expression", entries) +startMenu :: InstallEnv -> (String, [Shortcut]) +startMenu ienv = ("School of Expression", entries) where + iconDir = lFile (toolDir ienv) "icons" + entries :: [Shortcut] entries = [ Shortcut "Source code" - "c:\\src\\soelib\\src\\Code.html" + (lFile (srcDir ienv) "src\\Code.html") "" "Example code" - (Just ("c:\\src\\bamse\\soe\\html.exe")) + (Just (lFile iconDir "html.exe")) 1 "[TARGETDIR]src" ] -desktopShortcuts :: [Shortcut] -desktopShortcuts = [] +desktopShortcuts :: InstallEnv -> [Shortcut] +desktopShortcuts _ienv = [] -extensions :: [ Extension ] -extensions = [] +extensions :: InstallEnv -> [ Extension ] +extensions _ienv = [] verbs :: [ ( String -- extension , String -- verb @@ -100,19 +86,50 @@ ] verbs = [] -dirTrees :: IO [DirTree] -dirTrees = do - fs <- findFiles ofInterest (srcDir ++ "\\soelib") - return [fs] +dirTree :: InstallEnv -> IO DirTree +dirTree ienv = do + fs <- findFiles ofInterest (srcDir ienv ++ "\\soelib") + return fs where ofInterest file = not (last file == '~') -license :: Maybe FilePath -license = Nothing -- Just "c:\\src\\soelib\\license.rtf" +license :: InstallEnv -> Maybe FilePath +license _ienv = Nothing -- Just "c:\\src\\soelib\\license.rtf" userRegistration :: Bool userRegistration = False defaultInstallFolder :: Maybe String defaultInstallFolder = Nothing + + +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 :: [(FilePath,Maybe String)] +nestedInstalls = [] + +cabalPackageInfo :: Maybe CabalPackage +cabalPackageInfo = Nothing + +assemblies :: [Assembly] +assemblies = [] diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,37 @@ +module Main where + +import Bamse.Util.List +import Test.QuickCheck +import Test.HUnit + +instance Arbitrary Char where + arbitrary = choose ('\x20','\x80') + coarbitrary c = variant (fromEnum c `mod` 4) + +unitSplit :: Test +unitSplit = TestList $ + zipWith (\ t i -> ("Bamse.Util.List.split-"++show i) ~: t) + [ ["a","b","c"] ~=? (split ',' "a,b,c") + , ["a","b","c"] ~=? (split ',' "a,b,c,") + ] + [(1::Integer)..] + +unitList :: Test +unitList = TestList + [ unitSplit + ] + +quickList :: IO () +quickList = do + quickCheck (\ s -> null s == null (init0 s) || init0 (s::String) == take (length s - 1) s) + +checkList :: IO () +checkList = do + quickList + c <- runTestTT unitList + putStrLn (showCounts c) + +main :: IO () +main = do + checkList + diff --git a/tools/Wrapper.hs b/tools/Wrapper.hs new file mode 100644 --- /dev/null +++ b/tools/Wrapper.hs @@ -0,0 +1,17 @@ +module Main(main) where + +import System.Cmd +import System.Environment +import System.Directory +import System.Exit + +main :: IO () +main = do + ls <- getArgs + case ls of + (c:a:xs) -> do + setCurrentDirectory c + ex <- rawSystem a xs + exitWith ex + + diff --git a/tools/custWrap.exe b/tools/custWrap.exe new file mode 100644 Binary files /dev/null and b/tools/custWrap.exe differ diff --git a/tools/msiIcon.c b/tools/msiIcon.c --- a/tools/msiIcon.c +++ b/tools/msiIcon.c @@ -168,7 +168,7 @@ // It's an .ico file; copy it. return CopyFileW(dllName, fName, FALSE); } - fwprintf(stderr, L"WriteIcon: Couldn't load '%s'\n", dllName); + fprintf(stderr, "WriteIcon: Couldn't load '%s'\n", dllName); return FALSE; }