Skip to content
Browse files

Prettify code, rearrange some stuff, do a little work on generating t…

…he package .info file
  • Loading branch information...
1 parent 78fa901 commit 4cd74ad8268e16d0d83db307d0de012d32a2e196 @gregorycollins committed Feb 3, 2009
Showing with 287 additions and 174 deletions.
  1. +15 −14 LICENSE
  2. +272 −160 Main.hs
View
29 LICENSE
@@ -1,30 +1,31 @@
-Copyright (c) 2008 Gregory D. Collins
+Copyright (c) 2008-2009 Gregory D. Collins
All rights reserved.
Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions
-are met:
+modification, are permitted provided that the following conditions are
+met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
- documentation and/or other materials provided with the distribution.
+ documentation and/or other materials provided with the
+ distribution.
3. Neither the name of the author nor the names of his contributors
- may be used to endorse or promote products derived from this software
- without specific prior written permission.
+ may be used to endorse or promote products derived from this
+ software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
-ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
-STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
-ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-POSSIBILITY OF SUCH DAMAGE.
+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
View
432 Main.hs
@@ -1,34 +1,61 @@
-- |
-- Module : cabal2macpkg: convert cabal packages to OSX package format
--- Copyright : (c) Gregory D. Collins, 2008
+-- Copyright : (c) Gregory D. Collins, 2008-2009
-- License : BSD3
---
-- Maintainer: greg@gregorycollins.net
--- Stability : early stage project
--
-- Loosely based on cabal2arch by Don Stewart.
--
-- Rough outline of the process:
--
--- 1) find a .cabal file in the current working directory
--- 2) run "cabal build; cabal haddock" into a staging area
--- 3) run "cabal register --gen-script" to generate a registration
--- script that will be run by the OS X installer
--- 4) turn the staging area into a mac package file using the OS X
--- developer tools
+-- 1. find a .cabal file in the current working directory
+--
+-- 2. run @cabal build; cabal haddock@ into a staging area
+--
+-- 3. run @cabal register --gen-script@ to generate a registration
+-- script that will be run by the OS X installer
+--
+-- 4. turn the staging area into a mac package file using the OS X
+-- developer tools
--
-- A consequence of this quick n' dirty approach is that in order to
-- build the installer for a cabal package, you need to have already
-- installed all of its dependencies on the build machine.
+module Main (
+ -- * Program entry point
+ main
+ , runMain
+
+ -- * Command-line options
+ , Options(..)
+ , getOptions
+ , optionFlags
+ , usage
+
+ -- * Macintosh @PackageInfo@ files
+ , KVPs(..)
+ , PackageInfo(..)
+ , packageInfoDefaults
+ , packageInfoFields
+
+ -- * The \"heavy lifting\"
+ , makeMacPkg
+
+ -- * Misc. helper functions
+ , cleanupTempDirectory
+ , getTempDirectory
+ , runCmd
+ ) where
+
import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
import Distribution.PackageDescription.Parse
import Distribution.Simple.Build
import Distribution.Simple.Configure
import Distribution.Simple.Setup
-import Distribution.Simple.Utils
+import Distribution.Simple.Utils hiding (intercalate)
import Distribution.Verbosity as Verbosity
import qualified Data.ByteString.Lazy as B
@@ -56,7 +83,11 @@ import System.Process
import System.Posix.User (getEffectiveUserName)
-
+------------------------------------------------------------------------
+-- | Program entry point. Parses command line options, creates a
+-- scratch directory, runs the package building process, and cleans up
+-- after itself.
+------------------------------------------------------------------------
main :: IO ()
main = do
options <- getOptions
@@ -66,113 +97,74 @@ main = do
-runMain :: Options -> String -> IO ()
-runMain options tmpdir = do
- findPackageDesc "." >>= makeMacPkg options tmpdir
-
-
------------------------------------------------------------------------
--- mac packageinfo files
+-- | The guts of the program. Given the command-line options and a
+-- temp directory path, searches the current working directory for a
+-- .cabal file and builds an OSX package file based on its contents.
------------------------------------------------------------------------
-type PackageInfo = Map.Map String String
-
-
--- I stole this stuff from some python code, documentation for the
--- various file formats is difficult to find
-packageInfoFields = [
- "Title"
- , "Version"
- , "Description"
- , "DefaultLocation"
- , "DeleteWarning"
- , "NeedsAuthorization"
- , "DisableStop"
- , "UseUserMask"
- , "Application"
- , "Relocatable"
- , "Required"
- , "InstallOnly"
- , "RequiresReboot"
- , "RootVolumeOnly"
- , "LongFilenames"
- , "LibrarySubdirectory"
- , "AllowBackRev"
- , "OverwritePermissions"
- , "InstallFat"]
-
-
-packageInfoDefaults :: PackageInfo
-packageInfoDefaults = Map.fromList [
- ("Title" , "" )
- , ("Version" , "" )
- , ("Description" , "" )
- , ("DefaultLocation" , "/" )
- , ("DeleteWarning" , "" )
- , ("NeedsAuthorization" , "NO" )
- , ("DisableStop" , "NO" )
- , ("UseUserMask" , "YES" )
- , ("Application" , "NO" )
- , ("Relocatable" , "YES" )
- , ("Required" , "NO" )
- , ("InstallOnly" , "NO" )
- , ("RequiresReboot" , "NO" )
- , ("RootVolumeOnly" , "NO" )
- , ("InstallFat" , "NO" )
- , ("LongFilenames" , "YES" )
- , ("LibrarySubdirectory" , "Standard")
- , ("AllowBackRev" , "YES" )
- , ("OverwritePermissions" , "NO" )
- ]
-
+runMain :: Options -- ^ command-line options
+ -> FilePath -- ^ temp directory path
+ -> IO ()
+runMain options tmpdir =
+ findPackageDesc "." >>= makeMacPkg options tmpdir
-packageInfoToString :: PackageInfo -> String
-packageInfoToString pkg = e `concatMap` alist
- where
- alist = Map.toAscList pkg
- e (k,v) = k ++ " " ++ v ++ "\n"
------------------------------------------------------------------------
-- program options
------------------------------------------------------------------------
+
+------------------------------------------------------------------------
+-- | A monoid instance for the command-line options allows us to build
+-- up the options object from parts, i.e.:
+-- @
+-- a \``mappend`\` b
+-- @
+-- will build an Options object where the fields of @a@ are overridden
+-- by the non-'Nothing' fields of @b@
data Options = Options {
- installPrefix :: Maybe String,
- packageMakerPath :: Maybe String,
- showUsage :: Bool
+ installPrefix :: Maybe String -- ^ the installation prefix
+ -- for the generated library
+
+ , packageMakerPath :: Maybe String -- ^ path to the OSX
+ -- packagemaker binary (we'll
+ -- choose a sane default here)
+
+ , showUsage :: Bool -- ^ if true, show the usage
+ -- message, either because the
+ -- user requested it or
+ -- because of an error parsing
+ -- the command line arguments
} deriving (Eq, Show)
-------------------------------------------------------------------------
instance Monoid Options where
- mempty = Options { installPrefix = Just "/usr/local"
- , showUsage = False
- -- TODO: allow packageMakerPath to be overridden
+ mempty = Options { installPrefix = Just "/usr/local"
+ , showUsage = False
, packageMakerPath = Just "/Developer/usr/bin/packagemaker"
}
+
a `mappend` b =
Options {
- installPrefix = ip
- , packageMakerPath = pmp
- , showUsage = (showUsage a) || (showUsage b)
+ installPrefix = override installPrefix
+ , packageMakerPath = override packageMakerPath
+ , showUsage = showUsage a || showUsage b
}
where
- ipa = installPrefix a
- ipb = installPrefix b
-
- pmpa = packageMakerPath a
- pmpb = packageMakerPath b
+ (+) a b = getLast $ (Last a) `mappend` (Last b)
+ override f = (f a) + (f b)
- ip = if isJust ipb then ipb else ipa
- pmp = if isJust pmpb then pmpb else pmpa
------------------------------------------------------------------------
+-- | list of the option flags we accept (for GetOpt)
+optionFlags :: [GetOpt.OptDescr Options]
optionFlags = [ GetOpt.Option
- ['h']
+ "h"
["help"]
(GetOpt.NoArg $ mempty {showUsage=True})
"prints usage statement"
, GetOpt.Option
- []
+ ""
["prefix"]
(GetOpt.OptArg mkPrefix "DIR")
"installation prefix directory" ]
@@ -182,14 +174,16 @@ optionFlags = [ GetOpt.Option
------------------------------------------------------------------------
-usage :: [String] -> IO a
+-- | prints the usage statement
+usage :: [String] -- ^ list of error messages
+ -> IO a
usage errs = do
- putStrLn $ (usageString header) ++ errstr
+ putStrLn $ usageString header ++ errstr
exitFailure
where
usageString :: String -> String
- usageString = flip GetOpt.usageInfo $ optionFlags
+ usageString = flip GetOpt.usageInfo optionFlags
preamble =
"cabal2macpkg is a tool to create OSX installer packages\
@@ -201,9 +195,12 @@ usage errs = do
++ "\n" ++ (const '-' `map` usageLine) ++ "\n"
errstr = if null errs then ""
- else "\n" ++ (concat errs)
+ else '\n' : concat errs
+------------------------------------------------------------------------
+-- | parses the command line arguments -- shows usage screen and bails
+-- upon error
getOptions :: IO Options
getOptions = do
args <- getArgs
@@ -212,7 +209,9 @@ getOptions = do
(o,n,[]) -> return $ mconcat o
(_,_,errs) -> usage errs
- if showUsage opts then usage [] else return opts
+ if showUsage opts
+ then usage []
+ else return opts
------------------------------------------------------------------------
-- end options stuff
@@ -221,40 +220,99 @@ getOptions = do
------------------------------------------------------------------------
--- TODO: this function getting unwieldy, refactor
-makeMacPkg :: Options -> FilePath -> FilePath -> IO ()
-makeMacPkg options tmpdir cabalFile = do
- -- some portions of package building process require root
- -- privileges
- whoiam <- getEffectiveUserName
+-- types & functions for mac packageinfo files
+------------------------------------------------------------------------
- if whoiam /= "root" then
- die "must be root to run cabal2macpkg"
- else
- return ()
+type KVPs = Map.Map String String
- -- build into our temporary directory
- createDirectory stagingDir
- createDirectory scriptsDir
- createDirectory contentsDir
+-- | a @PackageInfo@ file is just a key-value pair mapping. We'll wrap
+-- it in a newtype so we can define a custom 'Show' instance
+newtype PackageInfo = PackageInfo KVPs
- putStrLn $ "found a cabal file at '" ++ cabalFile ++ "'"
- pkgDesc <- flattenPackageDescription `liftM`
- (readPackageDescription Verbosity.normal cabalFile)
+-- | The 'packageInfoFields' variable stores a list of the available
+-- fields for package .info files. Currently not in use, it's mostly
+-- for reference. I stole this stuff from some python code,
+-- documentation for the various Mac file formats is difficult to find
+packageInfoFields :: [String]
+packageInfoFields = [
+ "Title"
+ , "Version"
+ , "Description"
+ , "DefaultLocation"
+ , "DeleteWarning"
+ , "NeedsAuthorization"
+ , "DisableStop"
+ , "UseUserMask"
+ , "Application"
+ , "Relocatable"
+ , "Required"
+ , "InstallOnly"
+ , "RequiresReboot"
+ , "RootVolumeOnly"
+ , "LongFilenames"
+ , "LibrarySubdirectory"
+ , "AllowBackRev"
+ , "OverwritePermissions"
+ , "InstallFat"]
- let packageVersion = "0.0-FIXME"
- --------------------------------------------------------------------
- runSetup "configure" ["--global", "--prefix=" ++ prefix]
- runSetup "build" []
- runSetup "haddock" []
- runSetup "copy" ["--destdir=" ++ contentsDir]
- runSetup "register" ["--gen-script"]
+-- | defaults for the packageinfo file
+packageInfoDefaults :: KVPs
+packageInfoDefaults = Map.fromList [
+ ("Title" , "" )
+ , ("Version" , "" )
+ , ("Description" , "" )
+ , ("DefaultLocation" , "/" )
+ , ("DeleteWarning" , "" )
+ , ("NeedsAuthorization" , "YES" )
+ , ("DisableStop" , "NO" )
+ , ("UseUserMask" , "YES" )
+ , ("Application" , "NO" )
+ , ("Relocatable" , "NO" )
+ , ("Required" , "NO" )
+ , ("InstallOnly" , "NO" )
+ , ("RequiresReboot" , "NO" )
+ , ("RootVolumeOnly" , "YES" )
+ , ("InstallFat" , "NO" )
+ , ("LongFilenames" , "YES" )
+ , ("LibrarySubdirectory" , "Standard")
+ , ("AllowBackRev" , "YES" )
+ , ("OverwritePermissions" , "NO" )
+ ]
+
+
+instance Show PackageInfo where
+ show (PackageInfo pkg) = e `concatMap` alist
+ where
+ alist = Map.toAscList pkg
+ e (k,v) = k ++ " " ++ v ++ "\n"
+
+
+
+
+------------------------------------------------------------------------
+-- "the guts"
+------------------------------------------------------------------------
+
+------------------------------------------------------------------------
+-- | the 'makeMacPkg' function does (or will do) all of the dirty work
+-- of building the .pkg files
+makeMacPkg :: Options -- ^ command-line options
+ -> FilePath -- ^ path to temp directory
+ -> FilePath -- ^ path to .cabal file
+ -> IO ()
+makeMacPkg options tmpdir cabalFile = do
+ -- some portions of package building process require root
+ -- privileges
+ checkRootPrivileges
+ createDirectories
- copyFile "register.sh" $ postflightScriptFile
- runCmd "chmod" ["+x", postflightScriptFile]
- removeFile "register.sh"
+ pkgDesc <- flattenPackageDescription `liftM`
+ readPackageDescription Verbosity.normal cabalFile
+
+ --------------------------------------------------------------------
+ buildPackageContents
-- TODO: setRootPrivileges will make sure the generated files have
-- the correct username & permissions
@@ -263,73 +321,128 @@ makeMacPkg options tmpdir cabalFile = do
-- make .info file
mkInfoFile
+ where
+ --------------------------------------------------------------------
+ -- variables
+ --------------------------------------------------------------------
+ cabalBuildDir = tmpdir </> "dist"
+ contentsDir = stagingDir </> "Contents"
+ infoPath = tmpdir </> (pkgTitle ++ ".info")
+ packageMaker = fromJust $ packageMakerPath options
+ postflightScriptFile = resourceDir </> "postflight"
+ prefix = fromJust $ installPrefix options
+ resourceDir = tmpdir </> "Resources"
+ stagingDir = tmpdir </> "stage"
- where
- -- installPrefix guaranteed not nothing
- prefix = fromJust $ installPrefix options
- cabalBuildDir = tmpdir </> "dist"
- scriptsDir = tmpdir </> "Resources"
- stagingDir = tmpdir </> "stage"
- contentsDir = stagingDir </> "Contents"
+ -- path to output file
+ pkgDestinationFile :: FilePath
+ pkgDestinationFile = tmpdir </> "FIXME.pkg"
- postflightScriptFile = scriptsDir </> "postflight"
- infoPath = tmpdir </> "package.info"
+ -- TODO: fill in package identifier based on contents of cabal file
+ pkgDesc = "FIXME-Description"
+ pkgIdentifier = ""
+ pkgTitle = "FIXME-PkgTitle"
+ pkgVersion = "0.0-FIXME"
- runSetup :: String -> [String] -> IO ()
- runSetup cmd opts =
- runCmd "runghc" $ ["Setup", cmd] ++ (mkOpts opts)
+ --------------------------------------------------------------------
+ -- helper I/O actions
+ --------------------------------------------------------------------
- mkOpts s = s ++ ["--builddir=" ++ cabalBuildDir]
+ --------------------------------------------------------------------
+ -- checks that we're root and bails if not
+ checkRootPrivileges :: IO ()
+ checkRootPrivileges = do
+ whoiam <- getEffectiveUserName
+ when (whoiam /= "root") $ die "must be root to run cabal2macpkg"
- packageMaker :: String
- -- note "packageMakerPath options" guaranteed not Nothing
- packageMaker = fromJust $ packageMakerPath options
+ --------------------------------------------------------------------
+ -- creates necessary directories inside the work area
+ createDirectories =
+ createDirectory `mapM_` [stagingDir, resourceDir, contentsDir]
- -- TODO: fill in package identifier based on contents of cabal file
- pkgIdentifier :: String
- pkgIdentifier = ""
- packageTitle :: String
- packageTitle = "FIXME"
+ --------------------------------------------------------------------
+ -- uses cabal to build the package into the work area
+ buildPackageContents = do
+ runSetup "configure" ["--global", "--prefix=" ++ prefix]
+ runSetup "build" []
+ runSetup "haddock" []
+ runSetup "copy" ["--destdir=" ++ contentsDir]
+ runSetup "register" ["--gen-script"]
- -- path to output file
- pkgDestinationFile :: FilePath
- pkgDestinationFile = tmpdir </> "FIXME.pkg"
+ copyFile "register.sh" postflightScriptFile
+ runCmd "chmod" ["+x", postflightScriptFile]
+ removeFile "register.sh"
- -- TODO: fill out info file here
+ --------------------------------------------------------------------
+ -- populate the package .info file in the resource directory
mkInfoFile :: IO ()
- mkInfoFile = return ()
+ mkInfoFile =
+ writeFile infoPath (show pinfo)
+ where
+ defaults = packageInfoDefaults
+ overrides = Map.fromList [
+ ("Title", pkgTitle)
+ , ("Version", pkgVersion)
+ , ("Description", pkgDesc)
+ ]
+
+ pinfo = PackageInfo $ Map.union overrides defaults
-- TODO: make sure files are owned by root and have correct
-- permissions
setRootPrivileges :: IO ()
setRootPrivileges = return ()
+
+ --------------------------------------------------------------------
+ -- helper functions
+ --------------------------------------------------------------------
+
+ -- | runs Setup.[l]hs with the given subcommand and arguments
+ runSetup :: String -- ^ subcommand of Setup.hs,
+ -- i.e. "configure"/"build"/etc
+ -> [String] -- ^ additional arguments
+ -> IO ()
+ runSetup cmd opts =
+ runCmd "runghc" $ ["Setup", cmd] ++ mkOpts opts
+ where
+ mkOpts s = s ++ ["--builddir=" ++ cabalBuildDir]
+
+
+
+------------------------------------------------------------------------
+-- misc. useful functions
+------------------------------------------------------------------------
+
+
------------------------------------------------------------------------
-- |
-- run a subprocess with the given arguments, ignoring the output. Die
--- if the program returns an error.
+-- if the program returns a nonzero status code
--
-runCmd :: String -> [String] -> IO ()
+runCmd :: String -- ^ command to run
+ -> [String] -- ^ command arguments
+ -> IO ()
runCmd cmd args = do
e <- rawSystem cmd args
case e of ExitSuccess -> return ()
- ExitFailure _ -> die $ "command failed: " ++
- cmd ++ " " ++ (Data.List.intercalate " " args)
+ ExitFailure _ -> die $ "command failed: "
+ ++ cmd ++ " "
+ ++ intercalate " " args
------------------------------------------------------------------------
--- |
--- grab a temporary directory and change into it. Returns the path to
--- the new directory and the path to the old working directory.
+-- | grab a temporary directory. Produces the path to the new
+-- directory.
--
getTempDirectory :: IO FilePath
getTempDirectory =
@@ -346,11 +459,10 @@ getTempDirectory =
------------------------------------------------------------------------
--- |
--- removes the temporary directory and returns back to the previous
--- cwd
+-- | cleans up a temporary directory
--
-cleanupTempDirectory :: FilePath -> IO ()
+cleanupTempDirectory :: FilePath
+ -> IO ()
cleanupTempDirectory dir = do
--removeDirectoryRecursive dir
putStrLn $ "temporary directory is '" ++ dir ++ "'"

0 comments on commit 4cd74ad

Please sign in to comment.
Something went wrong with that request. Please try again.