{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : cabal2arch: convert cabal packages to Arch Linux PKGBUILD format -- Copyright : (c) Don Stewart, 2008 -- License : BSD3 -- -- Maintainer: Don Stewart -- Stability : provisional -- Portability: -- -- TODO: libraries should be "haskell-$packagefoo" import Distribution.PackageDescription import Distribution.PackageDescription.Configuration import Distribution.Simple.Utils hiding (die) import Distribution.Verbosity import Distribution.Version import Distribution.Package import Distribution.License import Distribution.Text import Distribution.Compiler import Distribution.System import Distribution.Simple.PackageIndex import Data.Digest.MD5 import qualified Data.ByteString.Lazy as B import Control.Monad import Control.Concurrent import Control.Exception import qualified Control.Exception as C import Data.List import Data.Maybe import Data.Monoid import Text.PrettyPrint import System.Directory import System.Environment import System.Exit import System.FilePath import System.IO import System.Process main :: IO () main = bracket -- We do all our work in a temp directory (do cwd <- getCurrentDirectory etmp <- readProcess "mktemp" ["-d"] [] case etmp of Left _ -> die "Unable to create temp directory" Right d -> do let dir = makeValid (init d) -- drop newline setCurrentDirectory dir return (dir, cwd)) -- Always remember to clean up (\(d,cwd) -> do setCurrentDirectory cwd removeDirectoryRecursive d) -- Now, get to work: $ \(tmp,cwd) -> do do x <- getArgs case x of ["--help"] -> help ["-h"] -> help _ -> return () email <- maybe "" id `fmap` getEnvMaybe "DARCS_EMAIL" cabalfile <- findCabalFile cwd tmp hPutStrLn stderr $ "Using " ++ cabalfile cabalsrc <- readPackageDescription normal cabalfile -- Create a package description with all configurations resolved. let e_finalcabalsrc = finalizePackageDescription [] (Nothing :: Maybe (PackageIndex PackageIdentifier)) buildOS -- linux/x86_64 X86_64 (CompilerId GHC (Version [6,8,2] [])) -- now constrain it to solve in the context of a modern ghc only corePackages cabalsrc finalcabal <- case e_finalcabalsrc of Left deps -> die $ "Unresolved dependencies: " ++show deps Right (pkg,_) -> return $ pkg { buildDepends = removeCoreFrom (buildDepends pkg) } let (pkgbuild', hooks) = cabal2pkg finalcabal pkgbuild <- getMD5 pkgbuild' let doc = pkg2doc email pkgbuild setCurrentDirectory cwd writeFile "PKGBUILD" (render doc) -- print pkgname.install case hooks of Nothing -> return () Just i -> writeFile (install_hook_name (arch_pkgname pkgbuild')) i ------------------------------------------------------------------------ -- | Given an abstract pkgbuild, download the source bundle, -- and compute its md5, returning a modified PkgBuild with -- the md5 set. -- -- TODO we may want to use a local package. -- getMD5 :: PkgBuild -> IO PkgBuild getMD5 pkg@(PkgBuild { arch_source = ArchList [url] }) = do hPutStrLn stderr $ "Fetching " ++ url hFlush stderr eres <- readProcess "wget" [url] [] case eres of Left (_,s,_) -> do hPutStrLn stderr s die $ "Couldn't download package: " ++ show url Right _ -> do src <- B.readFile (takeBaseName url <.> "gz") let !md5sum = show (md5 src) return pkg { arch_md5sum = ArchList [md5sum] } getMD5 _ = die "Malformed PkgBuild" -- attempt to filter out core packages we've already satisified -- not actuall correct, since it doesn't take any version -- info into account. -- -- Really need to use satisfyDep or friends. -- TODO do this properly -- removeCoreFrom :: [Dependency] -> [Dependency] removeCoreFrom [] = [] removeCoreFrom (x@(Dependency n _):xs) = case find (\(Dependency k _) -> n == k) corePackages of Just _ -> removeCoreFrom xs Nothing -> x : removeCoreFrom xs -- -- Core packages and their versions. These come with -- ghc, so we should be right. -- -- TODO populate this based on a dynamic check. -- corePackages :: [Dependency] corePackages = [Dependency "array" (ThisVersion (Version [0,1,0,0] [])) ,Dependency "base" (ThisVersion (Version [3,0,1,0] [])) ,Dependency "bytestring" (ThisVersion (Version [0,9,0,1] [])) ,Dependency "Cabal" (ThisVersion (Version [1,2,3,0] [])) ,Dependency "containers" (ThisVersion (Version [0,1,0,1] [])) ,Dependency "directory" (ThisVersion (Version [1,0,0,0] [])) ,Dependency "filepath" (ThisVersion (Version [1,1,0,0] [])) ,Dependency "haskell98" (ThisVersion (Version [1,0,1,0] [])) ,Dependency "hpc" (ThisVersion (Version [0,5,0,0] [])) ,Dependency "old-locale" (ThisVersion (Version [1,0,0,0] [])) ,Dependency "old-time" (ThisVersion (Version [1,0,0,0] [])) ,Dependency "packedstring" (ThisVersion (Version [0,1,0,0] [])) ,Dependency "pretty" (ThisVersion (Version [1,0,0,0] [])) ,Dependency "process" (ThisVersion (Version [1,0,0,0] [])) ,Dependency "random" (ThisVersion (Version [1,0,0,0] [])) ,Dependency "template-haskell" (ThisVersion (Version [2,2,0,0] [])) ,Dependency "unix" (ThisVersion (Version [2,3,0,0] [])) ] {- Cabal-1.2.3.0, GLUT-2.1.1.1, HUnit-1.2.0.0, OpenAL-1.3.1.1, OpenGL-2.2.1.1, QuickCheck-1.1.0.0, X11-1.4.2, array-0.1.0.0, base-3.0.1.0, bytestring-0.9.0.1, cgi-3001.1.5.1, containers-0.1.0.1, directory-1.0.0.0, fgl-5.4.1.1, filepath-1.1.0.0, (ghc-6.8.2), haskell-src-1.0.1.1, haskell98-1.0.1.0, hpc-0.5.0.0, html-1.0.1.1, mtl-1.1.0.0, network-2.1.0.0, old-locale-1.0.0.0, old-time-1.0.0.0, packedstring-0.1.0.0, parallel-1.0.0.0, parsec-2.1.0.0, pretty-1.0.0.0, process-1.0.0.0, random-1.0.0.0, readline-1.0.1.0, regex-base-0.72.0.1, regex-compat-0.71.0.1, regex-posix-0.72.0.2, rts-1.0, stm-2.1.1.0, template-haskell-2.2.0.0, time-1.1.2.0, unix-2.3.0.0, xhtml-3000.0.2.1 -} -- Return the path to a .cabal file. -- If not arguments are specified, use ".", -- if the argument looks like a url, download that -- otherwise, assume its a directory -- findCabalFile :: FilePath -> FilePath -> IO FilePath findCabalFile cwd tmp = do args <- getArgs let epath | null args = Right cwd | "http://" `isPrefixOf` file = Left file | ".cabal" `isSuffixOf` file = Right (makeValid (joinPath [cwd,file])) | otherwise -- a directory path = Right file where file = head args -- download url to .cabal case epath of Left url -> do eres <- readProcess "wget" [url] [] case eres of Left (_,s,_) -> do hPutStrLn stderr s die $ "Couldn't download .cabal file: " ++ show url Right _ -> findPackageDesc tmp -- tmp dir -- it might be a .cabal file Right f | ".cabal" `isSuffixOf` f -> do b <- doesFileExist f if not b then die $ ".cabal file doesn't exist: " ++ show f else return f -- or assume it is a dir to a file: Right dir -> do b <- doesDirectoryExist dir if not b then die $ "directory doesn't exist: " ++ show dir else findPackageDesc dir ------------------------------------------------------------------------ -- Parsing and pretty printing: -- -- | Translate an abstract PkgBuild file into a document structure -- pkg2doc :: String -> PkgBuild -> Doc pkg2doc email pkg = vcat [ text "# Contributor:" <+> text email , text "pkgname" <=> text (arch_pkgname pkg) , text "pkgrel" <=> int (arch_pkgrel pkg) , text "pkgver" <=> disp (arch_pkgver pkg) , text "pkgdesc" <=> doubleQuotes (text (arch_pkgdesc pkg)) , text "url" <=> doubleQuotes (text (arch_url pkg)) , text "license" <=> disp (arch_license pkg) , text "arch" <=> disp (arch_arch pkg) , text "makedepends" <=> disp (arch_makedepends pkg) , text "source" <=> dispNoQuotes (arch_source pkg) , case arch_install pkg of Nothing -> empty Just p -> text "install" <=> disp p , text "md5sums" <=> disp (arch_md5sum pkg) , hang (text "build() {") 4 (vcat $ (map text) (arch_build pkg)) $$ char '}' ] -- -- | Tranlsate a generic cabal file into a PGKBUILD -- cabal2pkg :: PackageDescription -> (PkgBuild, Maybe String) cabal2pkg cabal -- TODO decide if its a library or an executable, -- handle mullltipackages -- extract C dependencies -- = trace (show _cabal_condExecutables ) $ = (emptyPkgBuild { arch_pkgname = archName , arch_pkgver = vers , arch_url = if null (homepage cabal) then "http://hackage.haskell.org/cgi-bin/hackage-scripts/package/"++name else homepage cabal , arch_pkgdesc = synopsis cabal , arch_license = ArchList . return $ case license cabal of GPL -> GPL LGPL -> LGPL l -> UnknownLicense ("custom:"++ show l) -- All Hackage packages depend on GHC at build time -- All Haskell libraries are prefixed with "haskell-" , arch_makedepends = (arch_makedepends emptyPkgBuild) `mappend` ArchList [ ArchDep (Dependency ("haskell" <-> d) v) | Dependency d v <- buildDepends cabal ] -- need the dependencies of all flags that are on by default, for all libraries and executables -- Hackage programs only need their own source to build , arch_source = ArchList . return $ "http://hackage.haskell.org/packages/archive/" ++ (name display vers name <-> display vers <.> "tar.gz") , arch_build = [ "cd $startdir/src/" name <-> display vers , "runhaskell Setup configure --prefix=/usr || return 1" , "runhaskell Setup build || return 1" ] ++ -- Only needed for libraries: (if hasLibrary then ["runhaskell Setup register --gen-script || return 1" ,"runhaskell Setup unregister --gen-script || return 1" ,"install -D -m744 register.sh $startdir/pkg/usr/share/haskell/$pkgname/register.sh" , "install -m744 unregister.sh $startdir/pkg/usr/share/haskell/$pkgname/unregister.sh" ] else []) ++ ["runhaskell Setup copy --destdir=$startdir/pkg || return 1"] ++ (if license cabal `notElem` [GPL,LGPL] then ["install -D -m644 " ++ licenseFile cabal ++ " $startdir/pkg/usr/share/licenses/$pkgname/LICENSE || return 1" ] else []) -- if its a library: , arch_install = if hasLibrary then Just $ install_hook_name archName else Nothing }, if hasLibrary then Just (install_hook archName) else Nothing ) where archName = if isLibrary then "haskell-" ++ name else name name = pkgName (package cabal) vers = pkgVersion (package cabal) hasLibrary = isJust (library cabal) isLibrary = isJust (library cabal) && null (executables cabal) -- -- post install, and pre-remove hooks to run, to sync up ghc-pkg -- install_hook_name :: String -> String install_hook_name pkgname = pkgname <.> "install" install_hook :: String -> String install_hook pkgname = unlines [ "HS_DIR=/usr/share/haskell/" ++ pkgname , "post_install() {" , " ${HS_DIR}/register.sh" , "}" , "pre_upgrade() {" , " ${HS_DIR}/unregister.sh" , "}" , "post_upgrade() {" , " ${HS_DIR}/register.sh" , "}" , "pre_remove() {" , " ${HS_DIR}/unregister.sh" , "}" , "op=$1" , "shift" , "$op $*" ] -- -- | A data type to represent PKGBUILD files -- data PkgBuild = PkgBuild { arch_pkgname :: String -- ^ -- The name of the package. This has be a unix-friendly name -- as it will be used in the package filename. , arch_pkgver :: Version -- ^ The version of the software as released from the authorii -- (e.g. ´2.7.1´). , arch_pkgrel :: !Int -- ^ -- This is the release number specific to the Arch Linux -- release. This allows package maintainers to make updates to -- the package´s configure flags, for example. A pkgrel of 1 -- is typically used for each upstream software release and is -- incremented for intermediate PKGBUILD updates. , arch_pkgdesc :: String -- ^ -- This should be a brief description of the package and its -- functionality. Try to keep the description to one line of text. , arch_arch :: ArchList ArchArch -- ^ -- Defines on which architectures the given package is -- available (e.g. arch=(´i686´ ´x86_64´)). , arch_url :: String -- ^ -- This field contains a URL that is associated with the software -- being packaged. This is typically the project´s website. , arch_license :: ArchList License -- ^ -- This field specifies the license(s) that apply to the package. -- Commonly-used licenses are found in /usr/share/licenses/common. If -- you see the package´s license there, simply reference it in the -- license field (e.g. license=(´GPL´)). If the package provides a -- license not found in /usr/share/licenses/common, then you should -- include the license in the package itself and set -- license=(´custom´) or license=(´custom:LicenseName´). The license -- should be placed in $pkgdir/usr/share/licenses/$pkgname when -- building the package. If multiple licenses are applicable for a -- package, list all of them: license=(´GPL´ ´FDL´). , arch_makedepends :: ArchList ArchDep -- ^ -- An array of packages that this package depends on to build, but are -- not needed at runtime. Packages in this list follow the same format -- as depends. , arch_depends :: ArchList ArchDep -- ^ -- An array of packages that this package depends on to run. Packages -- in this list should be surrounded with single quotes and contain at -- least the package name. Entries can also include a version -- requirement of the form name<>version, where <> is one of five -- comparisons: >= (greater than or equal to), <= (less than or equal -- to), = (equal to), > (greater than), or < (less than). , arch_source :: ArchList String -- ^ -- An array of source files required to build the package. Source -- files must either reside in the same directory as the PKGBUILD -- file, or be a fully-qualified URL that makepkg will use to download -- the file. In order to make the PKGBUILD as useful as possible, use -- the $pkgname and $pkgver variables if possible when specifying the -- download location. Any files that are compressed will automatically -- be extracted, unless found in the noextract array listed below. , arch_md5sum :: ArchList String -- ^ -- This array contains an MD5 hash for every source file specified in -- the source array (in the same order). makepkg will use this to -- verify source file integrity during subsequent builds. To easily -- generate md5sums, run “makepkg -g >> PKGBUILD”. If desired, move -- the md5sums line to an appropriate location. NOTE: makepkg -- supports multiple integrity algorithms and their corresponding -- arrays (i.e. sha1sums for the SHA1 algorithm); however, official -- packages use only md5sums for the time being. , arch_build :: [String] -- ^ -- The build hook , arch_install :: Maybe String -- ^ -- Specifies a special install script that is to be included in the package. This -- file should reside in the same directory as the PKGBUILD, and will be copied -- into the package by makepkg. It does not need to be included in the source -- array (e.g. install=pkgname.install). } deriving (Show, Eq) -- -- | An empty PKGBUILD -- emptyPkgBuild :: PkgBuild emptyPkgBuild = PkgBuild { arch_pkgname = pkgName (package e) , arch_pkgver = pkgVersion (package e) , arch_pkgrel = 1 , arch_pkgdesc = synopsis e , arch_arch = ArchList [Arch_X86, Arch_X86_64] , arch_url = homepage e , arch_license = ArchList [license e] , arch_makedepends = ArchList [(ArchDep (Dependency "ghc" AnyVersion))] -- makedepends=('ghc>=6.6') ? , arch_depends = ArchList [] , arch_source = ArchList [] , arch_md5sum = ArchList [] -- sha1sums=('a08670e4c749850714205f425cb460ed5a0a56b2') , arch_build = [] , arch_install = Nothing -- executable } where e = emptyPackageDescription ------------------------------------------------------------------------ -- Extra pretty printer instances and types newtype ArchDep = ArchDep Dependency deriving (Eq,Show) -- the PKGBUILD version spec is less expressive than cabal, we can't -- really handle unions or intersections well yet. instance Text ArchDep where disp (ArchDep (Dependency name ver)) = text name <> mydisp ver where -- >= (greater than or equal to), <= (less than or -- equal to), = (equal to), > (greater than), or < mydisp AnyVersion = empty mydisp (ThisVersion v) = text "=" <> disp v mydisp (LaterVersion v) = char '>' <> disp v mydisp (EarlierVersion v) = char '<' <> disp v mydisp (UnionVersionRanges (ThisVersion v1) (LaterVersion v2)) | v1 == v2 = text ">=" <> disp v1 mydisp (UnionVersionRanges (LaterVersion v2) (ThisVersion v1)) | v1 == v2 = text ">=" <> disp v1 mydisp (UnionVersionRanges (ThisVersion v1) (EarlierVersion v2)) | v1 == v2 = text "<=" <> disp v1 mydisp (UnionVersionRanges (EarlierVersion v2) (ThisVersion v1)) | v1 == v2 = text "<=" <> disp v1 {- mydisp (UnionVersionRanges r1 r2) = disp r1 <+> text "||" <+> disp r2 mydisp (IntersectVersionRanges r1 r2) = disp r1 <+> text "&&" <+> disp r2 -} mydisp x = error $ "Can't handle this version format yet: " ++ show x parse = undefined -- -- | Valid linux platforms -- data ArchArch = Arch_X86 | Arch_X86_64 deriving (Show, Eq) instance Text ArchArch where disp x = case x of Arch_X86 -> text "i686" Arch_X86_64 -> text "x86_64" parse = error "Text.parrse not defined for ArchList" -- Lists with quotes newtype ArchList a = ArchList [a] deriving (Show, Eq, Monoid, Functor) instance Text String where disp s = text s parse = error "Text.parse not defined for String" instance Text a => Text (ArchList a) where disp (ArchList xs) = parens (hcat (intersperse space (map (quotes . disp) xs))) parse = error "Text.parse not defined for ArchList" -- | Printing with no quotes dispNoQuotes :: Text a => ArchList a -> Doc dispNoQuotes (ArchList xs) = parens (hcat (intersperse space (map disp xs))) ------------------------------------------------------------------------ ------------------------------------------------------------------------ -- Some extras -- help :: IO a help = do hPutStrLn stderr $ unlines [ "cabal2pkg: [-h|--help] [directory|url]" , "" , " Generate PKGBUILD to stdout for .cabal file in or at " , "" , "Usage:" , " -h Display help message" , "" , "Arguments: " , " Look for .cabal file in " , " If directory is empty, use pwd" , " " , " Use .cabal file as source" , " " , " Download .cabal file from " ] exitWith ExitSuccess ------------------------------------------------------------------------ die :: String -> IO a die s = do hPutStrLn stderr $ "cabal2pkg:\n" ++ s exitWith (ExitFailure 1) (<=>) :: Doc -> Doc -> Doc x <=> y = x <> char '=' <> y (<->) :: String -> String -> String x <-> y = x ++ "-" ++ y -- Safe wrapper for getEnv getEnvMaybe :: String -> IO (Maybe String) getEnvMaybe name = handle (const $ return Nothing) (Just `fmap` getEnv name) ------------------------------------------------------------------------ -- -- Strict process reading -- readProcess :: FilePath -- ^ command to run -> [String] -- ^ any arguments -> String -- ^ standard input -> IO (Either (ExitCode,String,String) String) -- ^ either the stdout, or an exitcode and any output readProcess cmd args input = C.handle (return . handler) $ do (inh,outh,errh,pid) <- runInteractiveProcess cmd args Nothing Nothing output <- hGetContents outh outMVar <- newEmptyMVar forkIO $ (C.evaluate (length output) >> putMVar outMVar ()) errput <- hGetContents errh errMVar <- newEmptyMVar forkIO $ (C.evaluate (length errput) >> putMVar errMVar ()) when (not (null input)) $ hPutStr inh input takeMVar outMVar takeMVar errMVar ex <- C.catch (waitForProcess pid) (\_e -> return ExitSuccess) hClose outh hClose inh -- done with stdin hClose errh -- ignore stderr return $ case ex of ExitSuccess -> Right output ExitFailure _ -> Left (ex, errput, output) where handler (C.ExitException e) = Left (e,"","") handler e = Left (ExitFailure 1, show e, "")