bamse-0.9.2: Bamse/Writer.hs
--
-- (c) 2007, Galois, Inc.
--
-- Outputting an MSI database.
--
module Bamse.Writer (
outputMSI -- :: WriterEnv {- env (file to output to, etc.) -}
-- -> Package {- specification of package -}
-- -> FilePath {- directory where the package's
-- files are rooted -}
-- -> [Table] {- tables that need to be created -}
-- -> [(TableName, [Row])]
{- data to populate the tables with -}
-- -> [ReplaceRow] {- rows to replace in the base package -}
-- -> IO ()
, getProductCodes
) where
import qualified Prelude
import Prelude
import Bamse.MSITable
import Bamse.MSIExtra
import Bamse.Package
import Data.List
import Control.Monad
import System ( system, ExitCode(..) )
import Time ( getClockTime )
import Data.Maybe ( fromMaybe, mapMaybe )
import Directory ( removeFile, doesFileExist )
import System.IO
import Data.Char ( toUpper )
import Data.Int ( Int32 )
import Data.Bits
import Util.List ( mapFirstDefault, enclose )
import System.Win32.Com ( catchComException, throwIOComException )
import System.Win32.Com.Automation
( (#), coRun, coCreateObject,
isCoError, coGetErrorString,
isNullInterface,
Date, clockTimeToDate )
import Bamse.WindowsInstaller hiding ( sequence )
import Debug.Trace ( trace )
{-
Module: Writer
Purpose:
this module serialises an MS Installer package. An installer is
a database containing a number of tables describing what's supposed
to happen when the installer is run (to install / un-install the
package). We construct the database from the table data specified
in Haskell together with meta-data describing the package itself.
Comments:
The only export from this module is 'outputMSI' which coordinates
the steps involved in creating an MSI installer:
* creates base package (from external files).
* adds meta data describing package/installer.
* fills in the database tables making up the installer.
* (optionally) compress the MSI by running 'makecab'.
ToDo:
let you create a web-based installer.
-}
--
-- Function: outputMSI
--
-- Purpose: create a complete MSI installer given a set of
-- database rows and meta information describing
-- the package.
--
outputMSI :: WriterEnv
-> [Table]
-> [(TableName, [Row])]
-> [ReplaceRow]
-> IO ()
outputMSI env tables rows repls = do
-- ToDo: internalise (some/all) of the data contained
-- in these SDK-provided .msi templates.
let package = w_package env
let pkg = p_pkgInfo package
putStr "Creating base package..."
createBasePackage (w_toolDir env) (w_templateDir env) (w_outFile env)
putStrLn "done."
ip <- coCreateObject "WindowsInstaller.Installer" iidInstaller
flip catchComException (topHandler ip) $ do
putStr "Creating MSI tables.."
db <- ip # openDatabase (w_outFile env) (fromEnum MsiOpenDatabaseModeTransact)
db # createTables tables
putStrLn "done."
putStr "Writing out package data..."
db # writePackageInfo pkg (p_productGUID package) (p_revisionGUID package) ip
putStrLn "done."
putStr "Tidying up tables..."
db # storeTables tables rows ip
db # replaceRows repls
putStrLn "done."
putStrLn "Compressing installer contents.."
hFlush stdout
ip # makeCab (w_outFile env) (w_srcDir env) db
db # commit
putStrLn "All done!"
return ()
--
-- Function: getProductCodes
--
-- Purpose: Fetch the product and revision GUIDs from an MSI.
-- Use this when we're updating/re-generating an installer.
--
getProductCodes :: FilePath -> IO (String, String)
getProductCodes oFile = coRun $ do
flg <- doesFileExist oFile
when (not flg)
(ioError (userError ("Unable to locate: " ++ oFile)))
ip <- coCreateObject "WindowsInstaller.Installer" iidInstaller
flip catchComException (topHandler ip) $ do
db <- ip # openDatabase oFile (fromEnum MsiOpenDatabaseModeReadOnly)
(rec,_) <- db # fetchRow "Property"
[ ("Property", "ProductCode") ]
[ ("Value", Nothing) ]
prodC <- rec # getStringData 1
si <- db # getSummaryInformation (1::Int32)
revC <- si # getProperty0 (fromIntegral $ fromEnum PID_REVNUMBER)
return (prodC, revC)
topHandler ip err
| isCoError err = flip catch (\ e -> ioError e) $ do
let v = coGetErrorString err
rec <- ip # lastErrorRecord
len <- rec # getFieldCount
ls <- mapM (\ i -> rec # getStringData i)
[1 .. len]
ioError (userError (v ++
unlines (("\nDetails (first val is the error code): ") : map (" "++) ls)))
| otherwise = throwIOComException err
--
-- Function: storeTables
--
storeTables :: [Table]
-> [(TableName, [Row])]
-> Installer a
-> Database b
-> IO ()
storeTables tables rows ip db = mapM_ (writeTable ip db tables) augmented_rows
where
augmented_rows = commonUpTables $
mapMaybe toRowData $
foldl addRow rows default_rows
-- reduce the number of table views we have to perform by
-- commoning up entries with the same table name.
commonUpTables ts =
map (\ ls@((tnm,sz,_):_) -> (tnm, sz, concatMap (\ (_,_,xs) -> xs) ls)) $
groupBy (\ (t1,_,_) (t2,_,_) -> t1 == t2) ts
toRowData (tnm, rows) =
case lookup tnm tables of
Just cols
-> Just ( tnm
, length cols
, map (\ (tnm, vals) -> mapMaybe (toIdx tnm cols) vals) rows
)
Nothing -> trace ("storeTables: WARNING: unknown table " ++ tnm) $
Nothing
toIdx _ _cols (_, Nothing) = Nothing
toIdx tabNm cols (nm, Just v) =
case findIndex (\ (n,_) -> n == nm) cols of
Just x -> Just (x+1, v)
Nothing -> trace ("storeTable.toIdx: WARNING: unknown column " ++
show (nm,tabNm)) $
Nothing
addRow rows row@(tn,_) = mapFirstDefault (tn,[row]) (f row) rows
where
f tab@(tnm,_) (tn,rs2)
| tn == tnm = Just (tnm, tab : rs2)
| otherwise = Nothing
-- currently assume that the tables passed
-- in aren't 100% complete. (This isn't a good
-- place to store this extra table data tho.)
default_rows =
[ ( "Directory"
, [ "Directory" -=> Just (string "TARGETDIR")
, "DefaultDir" -=> Just (string "SourceDir")
]
)
, ( "Media"
, [ "DiskId" -=> Just (int 1)
, "LastSequence" -=> Just (int 1)
, "DiskPrompt" -=> Just (string "")
, "Cabinet" -=> Just (string "")
, "VolumeLabel" -=> Just (string "")
, "Source" -=> Just (string "")
]
)
]
writeTable :: Installer a
-> Database b
-> [Table]
-> (TableName, Int, [RowData])
-> IO ()
writeTable ip db tables (nm, sz, rows) = do
view <-
case insertRowSql tables nm of
Just query -> db # openView query
Nothing -> do
hPutStrLn stderr ("WARNING: unknown/new table " ++ nm)
hFlush stderr
case lookup nm tables of
Nothing -> ioError (userError $ "Unknown table: " ++ nm)
Just t -> do
db # newTable (nm,t)
case (insertRowSql tables nm) of
Nothing -> ioError (userError $ "Unknown table: " ++ nm)
Just q -> db # openView q
mapM_ (writeRow view) rows
view # close
return ()
where
writeRow view idx_vals = do
rec <- ip # createRecord (fromIntegral sz)
mapM_ (writeValue rec) idx_vals
catch (view # execute rec)
(\ err -> print (nm, insertRowSql tables nm, idx_vals) >> ioError err)
return ()
writeValue rec (idx_i, v) =
case v of
String s -> rec # setStringData idx s
Int i -> rec # setIntegerData idx (fromIntegral i)
Long l -> rec # setIntegerData idx (fromIntegral l)
File f -> catch
(rec # setStream idx f)
(\ ioe -> do
hPutStrLn stderr ("Unable to store file: " ++ show f)
ioError ioe)
where
idx :: Int32
idx = fromIntegral idx_i
insertRowSql :: [Table]
-> TableName
-> Maybe String
insertRowSql tables tabNm =
case lookup tabNm tables of
Nothing -> Nothing
Just cols -> Just $
unwords [ "INSERT INTO"
, backTick tabNm
, inParen $ concat (intersperse "," field_labels)
, "VALUES"
, inParen $ concat (intersperse "," field_values)
]
where
field_labels = map backTick field_labs
(field_labs, field_values) = unzip (map toFields cols)
toFields (nm, cVal) =
( nm
, case cVal of
(_,True,_) -> "?"
(True,_,_) -> "?"
(False,_,_) -> "?"
)
backTick :: String -> String
backTick s = enclose "`" "`" s
fwdTick :: String -> String
fwdTick s = enclose "'" "'" s
inParen :: String -> String
inParen s = enclose "(" ")" s
--
-- Function: writePackageInfo
--
-- Purpose: emit standard package info into new MSI database.
--
writePackageInfo :: Package
-> String
-> String
-> Installer a
-> Database b
-> IO ()
writePackageInfo pkg pguid rguid ip db = do
db # setSummaryInformation
[ (PID_TITLE, title pkg)
, (PID_SUBJECT, name pkg)
, (PID_AUTHOR, author pkg)
, (PID_COMMENTS, comment pkg)
, (PID_REVNUMBER, map toUpper rguid)
, (PID_APPNAME, name pkg)
]
view <- db # openMSITable "Property"
mapM_ (setPair ip view)
[ ("ProductCode", map toUpper pguid)
, ("ProductName", title pkg)
-- Don't hardwire the language.
-- , ("ProductLanguage", "1033")
, ("ProductVersion", productVersion pkg)
, ("Manufacturer", author pkg)
-- plumb package URL to here
-- , ("ARPURLINFOABOUT", webSite)
]
view # close
return ()
setPair :: Installer a
-> View b
-> (String,String)
-> IO ()
setPair inst view (name,val) = do
rec <- inst # createRecord 2
rec # setStringData 1 name
rec # setStringData 2 val
catch (view # execute rec)
(\ e -> putStrLn ("setPair failed: " ++ name) >> ioError e)
return ()
setSummaryInformation :: [(ProductIDTag, String)]
-> Database a
-> IO ()
setSummaryInformation info db = do
si <- db # getSummaryInformation (length info + 3)
Prelude.sequence (map (setProp si) info)
x <- getClockTime
d <- clockTimeToDate x
setProp si (PID_LASTPRINTED, d)
setProp si (PID_CREATE_DTM, d)
setProp si (PID_LASTSAVE_DTM, d)
si # persist
return ()
where
setProp si (pid, val) = do
si # setProperty0 (fromEnum32 pid) val
fromEnum32 :: Enum a => a -> Int32
fromEnum32 = fromIntegral . Prelude.fromEnum
--
-- Function: openMSITable
--
-- Purpose: open up a standard MSI table for insertion.
--
openMSITable :: TableName
-> Database a
-> IO (View ())
openMSITable tabName db = do
case (insertRowSql msiTables tabName) of
Nothing -> ioError (userError ("openMISTable: Unknown table -- " ++ tabName))
Just q -> db # openView q
--
-- Function: createTables
--
-- Purpose: given a set of tables, create those that
-- aren't already present in an MSI database.
--
createTables :: [Table]
-> Database a
-> IO ()
createTables tabs db = do
notTheres <- filterM isPresent tabs
mapM_ (\ t -> catch (db # newTable t)
(const (return ())))
notTheres
where
isPresent (tNm, _) = catch
(do
rc <- db # getTablePersistent tNm
case rc of
MsiEvaluateConditionFalse -> return False
MsiEvaluateConditionTrue -> return False
MsiEvaluateConditionNone -> return True
MsiEvaluateConditionError -> return True
)
(\ _ -> return True)
--
-- Function: createBasePackage
--
-- Purpose: Output a standard and minimal MSI database
-- to a file. Combines three MSI SDK-provided
-- files to do this, including one containing
-- a collection of user interface dialogs.
-- Comment: to avoid having to redo this everytime, the
-- three MSIs have been merged already, so we
-- just copy that single file (base.msi) instead.
--
createBasePackage :: FilePath -> FilePath -> FilePath -> IO ()
createBasePackage bamseDir tDir dest =
copyFile (tDir ++ "\\base.msi") dest
{-was:
copyFile (src ++ "\\Schema.msi") dest
mergePackage src dest "Sequence.msi"
mergePackage src dest "UISample.msi"
-}
copyFile :: String -> String -> IO ()
copyFile src dest = do
rc <- system ("copy /b \"" ++ src ++ '"':' ':'"':dest ++ "\" > nul")
case rc of
ExitSuccess{} -> return ()
_ -> putStrLn $ "ERROR: Unable to copy " ++ show src ++ " to " ++ show dest
mergePackage :: String
-> String
-> String
-> Installer a
-> IO ()
mergePackage src dest db ip = do
db1 <- ip # openDatabase src (fromEnum MsiOpenDatabaseModeTransact)
db2 <- ip # openDatabase dest (fromEnum MsiOpenDatabaseModeReadOnly)
let errorTable = "_MergeErrors"
flg <- db1 # merge db2 errorTable
when (not flg)
(hPutStrLn stderr
(unlines [ "Merging"
, src
, "with"
, dest
, "ran into trouble, see"
, errorTable
, "table for details"
]))
-- don't follow the MSI SDK's WiMerge.vbs script's lead &
-- drop the merge-error table.
db1 # commit
return ()
newTable :: Table -> Database a -> IO ()
newTable (tabNm, cols) db = do
let createStmt = createTable tabNm cols
view <- db # openView createStmt
view # execute ()
return ()
where
createTable nm ls =
unwords [ "CREATE TABLE"
, backTick nm
, inParen (concat (intersperse "," columns) ++ primKeys)
]
where
columns = map mkCol ls
primKeys
| null prims = ""
| otherwise = " PRIMARY KEY " ++ concat (intersperse "," (map (\ (x,_) -> x) prims))
prims = filter isPrimKey ls
isPrimKey (_,(_,f,_)) = f
mkCol (colNm, (nonNull, _isKey, cType))
= unwords [ backTick colNm
, tyStr
, nullStr
, locStr
]
where
nullStr = if nonNull then "NOT NULL" else ""
locStr = if isLoc then "LOCALIZABLE" else ""
(tyStr,isLoc) =
case cType of
INT -> ("SHORT", False)
LONG -> ("LONG", False)
LONGCHAR l -> ("LONGCHAR", l)
CHAR mbSz l -> (unwords ["CHAR", fromMaybe "" (fmap (inParen.show) mbSz)], l)
OBJECT -> ("OBJECT", False)
replaceRows :: [ReplaceRow] -> Database a -> IO ()
replaceRows repls db = do
mapM_ replRow repls
where
replRow (tabName, keys, vals) = db # replaceColumns tabName keys vals
replaceColumns :: String
-> [RowKey]
-> [Value]
-> Database a
-> IO ()
replaceColumns tabName keyVals newVals db =
catch
(do
(rec, view) <- db # fetchRow tabName keyVals newVals
zipWithM_ (setField rec) [1..] newVals
view # modify MsiViewModifyUpdate rec
view # close
return ())
(\ err -> do
hPutStrLn stderr (unwords [ "\nTable"
, show tabName
, ": unable to find any rows matching the following key/value pairs"
, show keyVals
])
hPutStrLn stderr (show err)
-- just ignore
return ())
where
setField rec idx (_,Nothing) = return ()
setField rec idx (_,Just val) =
case val of
String s -> rec # setStringData idx s
File f -> do
h <- openFile f ReadMode -- (BinaryMode ReadMode)
str <- hGetContents h
rec # setStringData idx str
hClose h
Int i -> rec # setIntegerData idx (fromIntegral i)
Long i -> rec # setIntegerData idx (fromIntegral i)
fetchRow :: String
-> [(ColumnName,String)]
-> [Value]
-> Database a
-> IO (Record (), View ())
fetchRow tabName keyVals vals db = do
-- hPutStrLn stderr (selectStmt tabName vals keyVals)
view <- db # openView (selectStmt tabName vals keyVals)
view # execute ()
rec <- view # fetch
when (isNullInterface rec)
(ioError (userError "no records selected"))
c <- rec # getFieldCount
when (c == 0)
(ioError (userError "no records selected"))
return (rec, view)
selectStmt tabName vals ls =
unwords ([ "SELECT"
, unwords fields
, "FROM"
, backTick tabName
, "WHERE"
] ++ stuff)
where
fields = intersperse ", " (map (backTick.fst) vals)
stuff = intersperse "AND" (map eq ls)
eq (colNm, key) = unwords [backTick colNm, "=", fwdTick key]
makeCab :: FilePath
-> FilePath
-> Database b
-> Installer a
-> IO ()
makeCab msiFile srcLoc db ip = do
let bName = "cabber"
let cabFile = "cabber.cab"
let cabName = '#':cabFile
let cabSize = "CDROM"
-- let compressType = "MSZIP"
let compressType = "LZX"
session <- ip # openPackage db
shortNames <- session # getMode MsiRunModeSourceShortNames
when (not (null srcLoc))
(session # setProperty1 "OriginalDatabase" (srcLoc ++ "\\"))
-- ToDo: allow different source folder to be set?
stat <- session # doAction "CostInitialize"
when (fromEnum stat /= fromEnum MsiDoActionStatusSuccess)
(hPutStrLn stderr "makeCab: CostInitialize failed")
-- sequence the File table
view <- db # openView "SELECT Sequence,Attributes FROM File"
catch (view # execute ())
(\ e -> putStrLn "File selection failed" >> ioError e)
let
findSeq lSeq = do
rec <- view # fetch
if (isNullInterface rec) then
return lSeq
else do
seq <- rec # getIntegerData 1
att <- rec # getIntegerData 2
findSeq (if ((att .&. 0x00004000) == 0) && (seq > lSeq) then seq else lSeq)
lSeq <- findSeq 0
view <- db # openView "SELECT File,FileName,Directory_,Sequence,File.Attributes FROM File,Component WHERE Component_=Component ORDER BY Directory_"
catch (view # execute ())
(\ e -> putStrLn "Directory selection failed" >> ioError e)
let ddfFile = bName ++ ".ddf"
hFile <- openFile ddfFile WriteMode
let ct = (0::Int)
hPutStrLn hFile
(unlines [ unwords ["; Generated from" , msiFile, "on", show ct]
, ".Set CabinetNameTemplate=" ++ bName ++ "*.CAB"
, ".Set CabinetName1=" ++ cabFile
, ".Set ReservePerCabineSize=8"
, ".Set MaxDiskSize=" ++ cabSize
, ".Set CompressionType=" ++ compressType
, ".Set CompressionLevel=7"
, ".Set CompressionMemory=21"
, ".Set InfFileLineFormat=(*disk#*) *file#*: *file* = *Size*"
, ".Set InfFileName=" ++ bName ++ ".INF"
, ".Set RptFileName=" ++ bName ++ ".RPT"
, ".Set InfHeader="
, ".Set InfFooter="
, ".Set DiskDirectoryTemplate=."
, ".Set Compress=ON"
, ".Set Cabinet=ON"
])
let
relabelFiles :: Int32 -> Bool -> [String] -> IO (Int32, Bool, [String])
relabelFiles lSeq addedFiles msgs = do
rec <- view # fetch
if (isNullInterface rec) then
return (lSeq, addedFiles, msgs)
else do
fKey <- rec # getStringData 1
fName <- rec # getStringData 2
folder <- rec # getStringData 3
sequ <- rec # getIntegerData 4
attrs <- rec # getIntegerData 5
if (attrs .&. 0x00002000) == 0
then do -- uncompressed.
lSeq' <- do
if sequ <= lSeq then do
rec # setIntegerData 4 (lSeq + 1)
view # modify MsiViewModifyUpdate rec
return (lSeq + 1)
else
return lSeq
let (short,long') = break (=='|') fName
let fName'
| null short = fName
| shortNames = short
| not (null long') = tail long'
| otherwise = fName
sPath <- catch (session # getSourcePath folder)
(\ e -> hPutStrLn stderr ("error: " ++ show (fKey,fName,folder)) >> ioError e)
let sourcePath = sPath ++ fName'
hPutStrLn hFile ("\"" ++ sourcePath ++ "\" " ++ fKey)
st <- ip # fileAttributes sourcePath
relabelFiles lSeq' True (if st == -1 then (sourcePath : msgs) else msgs)
else do
relabelFiles lSeq True msgs
(lSeq, addedFiles, msgs) <- relabelFiles lSeq False []
hClose hFile
when (not (null msgs))
(hPutStrLn stderr ("The following files were not available:" ++ show (unlines msgs)))
if not addedFiles
then do
hPutStrLn stderr "WARNING: no files in file table; is your installer really supposed to be file-less?"
return ()
else do
rc <- system $
unwords [ "makecab.exe /V0 /f"
, ddfFile
]
when (rc /= ExitSuccess)
(hPutStrLn stderr "makecab failed")
view <- db # openView "SELECT DiskId, LastSequence, Cabinet FROM Media ORDER BY DiskId"
view # execute ()
rec <- view # fetch
(rec,uMode) <-
if (isNullInterface rec) then do
rec <- ip # createRecord 3
rec # setIntegerData 1 1
return (rec, MsiViewModifyInsert)
else
return (rec, MsiViewModifyUpdate)
rec # setIntegerData 2 lSeq
rec # setStringData 3 cabName
view # modify uMode rec
sumInfo <- db # getSummaryInformation (3::Int32)
n <- now
sumInfo # setProperty0 11 n
sumInfo # setProperty0 13 n
sumInfo # setProperty0 15 (if shortNames then (3::Int32) else 2)
sumInfo # persist
view <- db # openView "SELECT `Name`,`Data` FROM _Streams"
view # execute ()
rec <- ip # createRecord 2
rec # setStringData 1 cabFile
rec # setStream 2 cabFile
view # modify MsiViewModifyAssign rec
return ()
-- remove residuals.
removeFile "cabber.INF" `catch` (\ _ -> return ())
removeFile "cabber.ddf" `catch` (\ _ -> return ())
removeFile "cabber.RPT" `catch` (\ _ -> return ())
removeFile "cabber.cab" `catch` (\ _ -> return ())
return ()
now :: IO Date
now = do
x <- getClockTime
d <- clockTimeToDate x
return d