--------------------------------------------------------------------
-- |
-- Module      : Bamse.Writer
-- Description : Outputting an MSI database
-- Copyright   : (c) Sigbjorn Finne, 2004-2009
-- License     : BSD3
--
-- Maintainer  : Sigbjorn Finne <sof@forkIO.com>
-- Stability   : provisional
-- Portability : portable
--
-- Outputting an MSI database.
-- 
-- 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.
-- 
--------------------------------------------------------------------
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
	      
	      , mergePackage
	      ) where

import qualified Prelude
import Prelude

import Bamse.MSITable
import Bamse.MSIExtra
import Bamse.Package

import Data.List 
import Control.Monad
import System.Cmd    ( system )
import System.Exit   ( ExitCode(..) )
import System.Time   ( getClockTime )
import Data.Maybe    ( fromMaybe, mapMaybe )
import System.Directory     ( removeFile, doesFileExist )
import System.IO
import Data.Char     ( toUpper )
import Data.Int      ( Int32 )
import Data.Bits

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,
		       isNullInterface, 
		       Date, clockTimeToDate )
import Bamse.WindowsInstaller hiding ( sequence )
import Debug.Trace   ( trace )

--
-- 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 :: Installer i -> Com_Exception -> IO a
topHandler ip err 
 | isCoError err = flip catchComException throwIOComException $ 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, rows1) = 
    case lookup tnm tables of
      Just cols
        -> Just ( tnm
		, length cols
		, map (\ (tnm1, vals) -> mapMaybe (toIdx tnm1 cols) vals) rows1
		)
      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 rows1 row@(tn,_) = mapFirstDefault (tn,[row]) (f row) rows1
   where
    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
   -- 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
     catchComException 
           (view # execute rec)
     	   (\ err -> print (nm, insertRowSql tables nm, idx_vals) >> throwIOComException 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)
       Bamse.MSITable.File f 
                -> catchComException
       			(rec # setStream idx f)
			(\ exn -> do
			   hPutStrLn stderr ("Unable to store file: " ++ show f)
			   throwIOComException exn)
   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 (nm,val) = do
  rec <- inst # createRecord 2
  rec # setStringData 1 nm
  rec # setStringData 2 val
  catchComException
        (view # execute rec)
  	(\ e -> putStrLn ("setPair failed: " ++ nm) >> throwIOComException 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 -> catchComException (db # newTable t) (const (return ())))
	notTheres
 where
  isPresent (tNm, _) = catchComException
    (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 = 
  catchComException 
    (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
      Bamse.MSITable.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 :: String -> [(String,a)] -> [(String,String)] -> String
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, val) = unwords [backTick colNm, "=", fwdTick val]

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
  fView <- db # openView "SELECT Sequence,Attributes FROM File"
  catchComException
        (fView # execute ())
  	(\ e -> putStrLn "File selection failed" >> throwIOComException e)
  let
    findSeq theView lSeq = do
      rec <- theView # fetch
      if (isNullInterface rec) then
         return lSeq
       else do
         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
        (dView # execute ())
  	(\ e -> putStrLn "Directory selection failed" >> throwIOComException 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 :: View () -> Int32 -> Bool -> [String] -> IO (Int32, Bool, [String])
     relabelFiles theView labSeq addedFiles msgs = do
        rec <- theView # fetch
	if (isNullInterface rec) then
	   return (labSeq, 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 <= labSeq then do
	          rec # setIntegerData 4 (labSeq + 1)
		  theView # modify MsiViewModifyUpdate rec
		  return (labSeq + 1)
	       else
	          return labSeq
	     let (short,long') = break (=='|') fName
	     let fName'
		  | null short = fName
		  | shortNames = short
		  | not (null long') = tail long'
		  | otherwise  = fName

	     sPath <- catchComException
	                    (session # getSourcePath folder)
	     		    (\ e -> hPutStrLn stderr ("error: " ++ show (fKey,fName,folder)) >> throwIOComException e)
	     let sourcePath = sPath ++ fName'
	     hPutStrLn hFile ("\"" ++ sourcePath ++ "\" " ++ fKey)
	     st <- ip # fileAttributes sourcePath
	     relabelFiles theView lSeq' True (if st == -1 then (sourcePath : msgs) else msgs)
	    else do
	     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)))
  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")
     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 (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
     sumInfo # setProperty0 13 n    
     sumInfo # setProperty0 15 (if shortNames then (3::Int32) else 2)
     sumInfo # persist
    
     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 ())
  removeFile "cabber.RPT" `catch` (\ _ -> return ())
  removeFile "cabber.cab" `catch` (\ _ -> return ())
  return ()

now :: IO Date
now = do
  x <- getClockTime
  d <- clockTimeToDate x
  return d