{-# 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 <dons@galois.com>
-- Stability : provisional
-- Portability:
--
-- TODO: if build-type: Configure, accurate C library dependecies
-- require downloading the source, and running configure
--
-- C libraries are dynamicall linked, should be listed in depends,
-- rather than makedepends
import Distribution.Package
import Distribution.PackageDescription
import Distribution.PackageDescription.Parse
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
-- from the archlinux package:
import Distribution.ArchLinux.PkgBuild
import Data.Digest.Pure.MD5
import qualified Data.ByteString.Lazy as B
import Control.Monad
import Control.Concurrent
import qualified Control.OldException as C
import Data.List
import Data.Maybe
import qualified Data.Map as M
import Data.Monoid
import Data.Char
import Debug.Trace
import Text.PrettyPrint
import Paths_cabal2arch
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import System.Process
main :: IO ()
main =
C.bracket
-- We do all our work in a temp directory
(do cwd <- getCurrentDirectory
etmp <- myReadProcess "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 <- do
r <- getEnvMaybe "ARCH_HASKELL"
case r of
Nothing -> do hPutStrLn stderr "Warning: ARCH_HASKELL environment variable not set. Set this to the maintainer contact you wish to use. \n E.g. 'Arch Haskell Team <arch-haskell@haskell.org>'"
return []
Just s -> return s
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,10,3] []))
-- 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
dir = arch_pkgname pkgbuild
setCurrentDirectory cwd
createDirectoryIfMissing False dir
setCurrentDirectory dir
writeFile "PKGBUILD" (render doc ++ "\n")
-- print pkgname.install
case hooks of
Nothing -> return ()
Just i -> writeFile (install_hook_name (arch_pkgname pkgbuild)) i
setCurrentDirectory cwd
system $ "rm -rf " ++ dir </> "{pkg,src,*.tar.gz}"
tarred <- myReadProcess "tar" ["-zcvvf",(dir <.> "tar.gz"), dir] []
case tarred of
Left (_,s,_) -> do
hPutStrLn stderr s
die "Unable to tar package"
Right _ -> putStrLn ("Created " ++ (cwd </> dir <.> "tar.gz"))
-- If the user created a .cabal2arch.log file, append log results there.
mh <- getEnvMaybe "HOME"
case mh of
Nothing -> return ()
Just home -> do
b <- doesFileExist $ home </> ".cabal2arch.log"
if not b
then return ()
else do
-- Log to build file.
appendFile (home </> ".cabal2arch.log") $ (show $ (,,)
(arch_pkgname pkgbuild ++ "-" ++ (render . disp $ arch_pkgver pkgbuild))
(arch_pkgdesc pkgbuild)
(arch_url pkgbuild)) ++ "\n"
------------------------------------------------------------------------
-- | 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 <- myReadProcess "wget" [url] []
case eres of
Left (_,s,_) -> do
hPutStrLn stderr s
hPutStrLn stderr $ "Couldn't download package: " ++ show url
return pkg
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.
--
-- TODO this should use configDependency to find the precise
-- versions we have available on Arch.
--
removeCoreFrom :: [Dependency] -> [Dependency]
removeCoreFrom [] = []
removeCoreFrom (x@(Dependency n vr):xs) =
case find (\(Dependency k _) -> n == k) corePackages of
-- haskell-parsec, haskell-quickcheck
Just (Dependency _ (ThisVersion v'))
| withinRange v' vr -> removeCoreFrom xs
Just (Dependency (PackageName "base") _)
-> removeCoreFrom xs
Just (Dependency _ AnyVersion) -> removeCoreFrom xs
_ -> x : removeCoreFrom xs
--
-- Core packages and their versions. These come with
-- ghc, so we should be right.
--
-- http://haskell.org/haskellwiki/Libraries_released_with_GHC
--
-- TODO populate this based on a dynamic check.
--
-- Check the page too.
--
corePackages :: [Dependency]
corePackages =
[
Dependency (PackageName "Cabal") (ThisVersion (Version [1,6,0,1] []))
,Dependency (PackageName "HUnit") (ThisVersion (Version [1,2,0,3] []))
,Dependency (PackageName "QuickCheck") (ThisVersion (Version [1,2,0,0] []))
,Dependency (PackageName "array") (ThisVersion (Version [0,2,0,0] []))
,Dependency (PackageName "base") (ThisVersion (Version [4,1,0,0] []))
,Dependency (PackageName "bytestring") (ThisVersion (Version [0,9,1,4] []))
,Dependency (PackageName "containers") (ThisVersion (Version [0,2,0,0] []))
,Dependency (PackageName "directory") (ThisVersion (Version [1,0,0,2] []))
,Dependency (PackageName "dph-base") (ThisVersion (Version [ 0,3 ] [] ))
,Dependency (PackageName "dph-par" ) (ThisVersion (Version [ 0,3 ] [] ))
,Dependency (PackageName "dph-prim-interface") (ThisVersion (Version [ 0,3 ] [] ))
,Dependency (PackageName "dph-prim-par" ) (ThisVersion (Version [ 0,3 ] [] ))
,Dependency (PackageName "dph-prim-seq" ) (ThisVersion (Version [ 0,3 ] [] ))
,Dependency (PackageName "dph-seq" ) (ThisVersion (Version [ 0,3 ] [] ))
-- removed:
-- ,Dependency (PackageName "editline") (AnyVersion)
,Dependency (PackageName "filepath") (ThisVersion (Version [1,1,0,1] []))
,Dependency (PackageName "ghc") (AnyVersion)
,Dependency (PackageName "ghc-prim") (AnyVersion)
,Dependency (PackageName "haskell-src") (ThisVersion (Version [1,0,1,3] []))
,Dependency (PackageName "haskell98") (ThisVersion (Version [1,0,1,0] []))
,Dependency (PackageName "hpc") (ThisVersion (Version [0,5,0,2] []))
,Dependency (PackageName "html") (ThisVersion (Version [1,0,1,2] []))
,Dependency (PackageName "integer") (ThisVersion (Version [0,1,0,0] []))
,Dependency (PackageName "mtl") (ThisVersion (Version [1,1,0,2] []))
,Dependency (PackageName "network") (ThisVersion (Version [2,2,0,1] []))
,Dependency (PackageName "old-locale") (ThisVersion (Version [1,0,0,1] []))
,Dependency (PackageName "old-time") (ThisVersion (Version [1,0,0,1] []))
,Dependency (PackageName "packedstring") (ThisVersion (Version [0,1,0,1] []))
,Dependency (PackageName "parallel") (ThisVersion (Version [1,1,0,0] []))
,Dependency (PackageName "parsec") (ThisVersion (Version [2,1,0,0] []))
,Dependency (PackageName "pretty") (ThisVersion (Version [1,0,1,0] []))
,Dependency (PackageName "process") (ThisVersion (Version [1,0,1,0] []))
,Dependency (PackageName "random") (ThisVersion (Version [1,0,0,1] []))
,Dependency (PackageName "regex-base") (ThisVersion (Version [0,72,0,2] []))
,Dependency (PackageName "regex-compat") (ThisVersion (Version [0,71,0,1] []))
,Dependency (PackageName "regex-posix") (ThisVersion (Version [0,72,0,2] []))
,Dependency (PackageName "stm") (ThisVersion (Version [2,1,1,2] []))
,Dependency (PackageName "syb") (ThisVersion (Version [0,1,0,0] []))
,Dependency (PackageName "template-haskell") (ThisVersion (Version [2,3,0,0] []))
-- ,Dependency (PackageName "time") (ThisVersion (Version [1,1,2,2] []))
,Dependency (PackageName "unix") (ThisVersion (Version [2,3,1,0] []))
,Dependency (PackageName "xhtml") (ThisVersion (Version [3000,2,0,1] []))
-- Dependency (PackageName "ALUT") (ThisVersion (Version [2,1,0,0] []))
-- ,Dependency (PackageName "cgi") (ThisVersion (Version [3001,1,5,1] []))
-- ,Dependency (PackageName "extensible-exceptions") (AnyVersion)
-- ,Dependency (PackageName "fgl") (ThisVersion (Version [5,4,1,1] [])) -- gone
-- ,Dependency (PackageName "GLUT") (ThisVersion (Version [2,1,1,1] []))
-- ,Dependency (PackageName "OpenAL") (ThisVersion (Version [1,3,1,1] [])) -- gone
-- ,Dependency (PackageName "readline") (ThisVersion (Version [1,0,1,0] []))
{-
ALUT-2.1.0.0 cgi-3001.1.5.1 network-2.1.0.0 regex-base-0.72.0.1
Cabal-1.2.3.0 containers-0.1.0.1 old-locale-1.0.0.0 regex-compat-0.71.0.1
GLUT-2.1.1.1 directory-1.0.0.0 old-time-1.0.0.0 regex-posix-0.72.0.2
HUnit-1.2.0.0 fgl-5.4.1.1 packedstring-0.1.0.0 stm-2.1.1.0
OpenAL-1.3.1.1 filepath-1.1.0.0 parallel-1.0.0.0 template-haskell-2.2.0.0
OpenGL-2.2.1.1 haskell-src-1.0.1.1 parsec-2.1.0.0 time-1.1.2.0
QuickCheck-1.1.0.0 haskell98-1.0.1.0 pretty-1.0.0.0 unix-2.3.0.0
array-0.1.0.0 hpc-0.5.0.0 process-1.0.0.0 xhtml-3000.0.2.1
base-3.0.1.0 html-1.0.1.1 random-1.0.0.0
bytestring-0.9.0.1 mtl-1.1.0.0 readline-1.0.1.0
-}
]
-- 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 <- myReadProcess "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
findCLibs :: PackageDescription -> [String]
findCLibs (PackageDescription { library = lib, executables = exe }) =
-- warn for packages not in list.
map (canonicalise . map toLower) (some ++ rest)
where
some = concatMap (extraLibs.buildInfo) exe
rest = case lib of
Nothing -> []
Just l -> extraLibs (libBuildInfo l)
canonicalise k = case M.lookup k translationTable of
Nothing -> trace ("WARNING: this library depends on a C library we do not know the pacman name for (" ++ map toLower k ++ ") . Check the C library names in the generated PKGBUILD File") $ map toLower k
Just s -> s
-- known pacman packages for C libraries we use:
translationTable = M.fromList
[("Imlib2", "imlib2")
,("SDL", "sdl")
,("alut", "freealut")
,("bz2", "bzip2")
,("cblas", "blas")
,("crack", "cracklib")
,("crypto", "openssl")
,("curl", "curl")
,("freetype", "freetype2")
,("glib", "glib2")
,("wmflite", "libwmf")
,("il", "devil")
,("jpeg", "libjpeg")
,("ldap", "libldap")
,("pcap", "libpcap")
,("png", "libpng")
,("x11", "libx11")
,("xrandr", "libxrandr")
,("xml2", "libxml2")
,("exif", "libexif")
,("tiff", "libtiff")
,("sndfile", "libsndfile")
,("gcrypt", "libgcrypt")
,("fftw3", "fftw")
,("pq", "postgresql")
,("ssl", "openssl")
,("wx", "wxgtk")
,("xenctrl", "xen")
,("odbc", "unixodbc")
,("z", "zlib")
,("curses", "ncurses")
,("xslt", "libxslt")
,("csound64", "csound5")
,("uuid", "e2fsprogs")
,("doublefann", "fann")
,("ev", "libev")
,("pthread", "")
,("m", "")
,("gl", "")
,("glu", "")
,("db_cxx", "")
,("db_cxx", "")
,("xdamage", "")
,("icui18n", "icu")
,("icuuc", "icu")
,("icudata", "icu")
,("netsnmp", "net-snmp")
,("asound", "alsa-lib")
,("ffi", "libffi")
,("ogg", "libogg")
,("theora", "libtheora")
]
-- atlas
shouldNotBeLibraries :: [String]
shouldNotBeLibraries =
["xmonad"
,"gitit"
,"l-seed"
,"hspresent"
,"haskell-platform"
,"xmonad-contrib"
,"lambdabot"
,"piet"
,"hsffig"
,"yi"
,"haddock"
,"hscolour"
,"line2pdf"
,"distract"
,"derive"
,"Hedi"
,"conjure"
,"clevercss"
,"cpphs"
,"backdropper"
,"darcs-beta"
,"gtk2hs"
,"darcs"
,"greencard"
-- the pandoc package doesnt' ship haskell-pandoc
-- ,"pandoc"
,"pugs-drift"
,"wol"
,"timepiece"
,"hledger"
,"hp2any-graph"
,"hp2any-manager"
]
-- translate some library dependencies to gtk names
--
gtk2hsIfy :: [Dependency] -> [Dependency]
gtk2hsIfy [] = []
gtk2hsIfy xs | foundSome = Dependency (PackageName "gtk2hs") AnyVersion :
[ v | v@(Dependency n _) <- xs
, n `notElem` gtkLibs ]
| otherwise = xs
where
foundSome = not . null $ filter (`elem` gtkLibs) (map unDep xs)
unDep (Dependency n _) = n
gtkLibs :: [PackageName]
gtkLibs = map PackageName
["glade" -- guihaskell
,"cairo"
,"glib"
,"gtk"
,"gconf"
,"gtkglext"
,"gtksourceview2"
,"mozembed"
,"svgcairo"
]
------------------------------------------------------------------------
-- 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 "# Package generated by cabal2arch" <+> disp version
, text "pkgname"
<=> text (arch_pkgname pkg)
, text "pkgrel"
<=> int (arch_pkgrel pkg)
, text "pkgver"
<=> disp (arch_pkgver pkg)
, text "pkgdesc"
<=> text (show (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)
, case arch_depends pkg of
ArchList [] -> empty
_ -> text "depends" <=> disp (arch_depends pkg)
, text "options" <=> disp (arch_options 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) $
=
(emptyPkgBuild
{ arch_pkgname = archName
, arch_pkgver = vers
, arch_url = "http://hackage.haskell.org/package/"++display name
-- else homepage cabal
, arch_pkgdesc = case synopsis cabal of
[] -> take 80 (description cabal)
s -> s
, 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 = if not hasLibrary
then my_makedepends
else ArchList [] -- makedepends should not duplicate depends
, arch_depends =
(if not (isLibrary)
then
ArchList [ArchDep (Dependency (PackageName "gmp") AnyVersion)]
`mappend`
anyClibraries
else ArchList [])
`mappend`
-- libraries have 'register-time' dependencies on
-- their dependent Haskell libraries.
--
(if hasLibrary then my_makedepends
else ArchList [])
-- 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/"
++ (display name </> display vers </> display name <-> display vers <.> "tar.gz")
, arch_build =
[ "cd ${srcdir}/" </> display name <-> display vers
, "runhaskell Setup configure --prefix=/usr --docdir=/usr/share/doc/${pkgname} || return 1"
, "runhaskell Setup build || return 1"
] ++
-- Only needed for libraries:
(if hasLibrary
then
[ "runhaskell Setup haddock || return 1"
, "runhaskell Setup register --gen-script || return 1"
, "runhaskell Setup unregister --gen-script || return 1"
, "install -D -m744 register.sh ${pkgdir}/usr/share/haskell/$pkgname/register.sh"
, "install -m744 unregister.sh ${pkgdir}/usr/share/haskell/$pkgname/unregister.sh"
, "install -d -m755 $pkgdir/usr/share/doc/ghc/libraries"
, "ln -s /usr/share/doc/${pkgname}/html ${pkgdir}/usr/share/doc/ghc/libraries/" ++ (display name)
]
else [])
++
["runhaskell Setup copy --destdir=${pkgdir} || return 1"]
++
(if not (null (licenseFile cabal)) && license cabal `notElem` [GPL,LGPL]
then
[ "install -D -m644 " ++ licenseFile cabal ++ " ${pkgdir}/usr/share/licenses/$pkgname/LICENSE || return 1"
, "rm -f ${pkgdir}/usr/share/doc/${pkgname}/LICENSE"
]
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 = map toLower (if isLibrary then "haskell-" ++ display name else display name)
name = pkgName (package cabal)
vers = pkgVersion (package cabal)
-- build time dependencies
my_makedepends =
(arch_makedepends emptyPkgBuild)
`mappend`
-- Haskell libraries
-- TODO: use a real package spec to compute these names
-- based on what is in Arch.
ArchList
[ ArchDep (Dependency (PackageName $
if d `notElem` shouldNotBeLibraries
then "haskell" <-> map toLower (display d) else display d) v)
| Dependency (PackageName d) v <- gtk2hsIfy (buildDepends cabal) ]
`mappend`
anyClibraries
`mappend`
ArchList [ ArchDep d | b <- allBuildInfo cabal
, d@(Dependency n _) <- buildTools b
, n /= PackageName "hsc2hs" ]
-- TODO: need a 'nub' in here.
hasLibrary = isJust (library cabal)
isLibrary = isJust (library cabal) -- && null (executables cabal)
&& map toLower (display name) `notElem` shouldNotBeLibraries
anyClibraries | null libs = ArchList []
| otherwise = ArchList libs
where
libs = [ ArchDep (Dependency (PackageName s) AnyVersion) | s <- nub (findCLibs cabal) ]
-- quickcheck 2.
-- parsec 3
--
-- 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"
, " (cd /usr/share/doc/ghc/libraries; ./gen_contents_index)"
, "}"
, "pre_upgrade() {"
, " ${HS_DIR}/unregister.sh"
, "}"
, "post_upgrade() {"
, " ${HS_DIR}/register.sh"
, " (cd /usr/share/doc/ghc/libraries; ./gen_contents_index)"
, "}"
, "pre_remove() {"
, " ${HS_DIR}/unregister.sh"
, "}"
, "post_remove() {"
, " (cd /usr/share/doc/ghc/libraries; ./gen_contents_index)"
, "}"
, "op=$1"
, "shift"
, "$op $*" ]
------------------------------------------------------------------------
-- Some extras
--
help :: IO a
help = do
hPutStrLn stderr $ unlines
[ "cabal2pkg: [-h|--help] [directory|url]"
, ""
, " Generate PKGBUILD to stdout for .cabal file in <directory> or at <url>"
, ""
, "Usage:"
, " -h Display help message"
, ""
, "Arguments: <directory>"
, " Look for .cabal file in <directory>"
, " If directory is empty, use pwd"
, " <file.cabal>"
, " Use .cabal file as source"
, " <url>"
, " Download .cabal file from <url>"
]
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 = C.handle (const $ return Nothing) (Just `fmap` getEnv name)
------------------------------------------------------------------------
--
-- Strict process reading
--
myReadProcess :: 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
myReadProcess 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, "")