-
Notifications
You must be signed in to change notification settings - Fork 1
/
Util.hs
116 lines (94 loc) · 3.8 KB
/
Util.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
-- |
-- Module : Cabal2Arch.Util: utility functions for cabal2arch
-- Copyright : (c) Don Stewart, 2008 .. 2010
-- License : BSD3
--
-- Maintainer: Arch Haskell Team <arch-haskell@haskell.org>
-- Stability : provisional
module Cabal2Arch.Util where
import Data.List
import Control.Monad
import Control.Concurrent
import qualified Control.Exception as CE
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import System.Process hiding(cwd)
import Control.Monad.Trans
import Control.Monad.Error
import Distribution.ArchLinux.SystemProvides
import Paths_cabal2arch
type IOErr a = ErrorT String IO a
------------------------------------------------------------------------
-- Read a file from a URL
--
getFromURL :: String -> IOErr String
getFromURL url = do
res <- liftIO (myReadProcess "curl" ["-f", url] "")
case res of
Left _ -> throwError ("Unable to retrieve " ++ url)
Right s -> liftIO (return s)
-- Read from a file
getFromFile :: String -> IOErr String
getFromFile path = do
b <- liftIO (doesFileExist path)
if not b
then throwError ("File " ++ path ++ " does not exist!")
else liftIO (readFile path)
getDefaultSystemProvides :: ErrorT String IO SystemProvides
getDefaultSystemProvides = getSystemProvidesFromPath =<< (liftIO $ getDataFileName "data")
-- getSystemProvidesFromPath "http://andromeda.kiwilight.com/~remy.oudompheng/arch-haskell/default"
getSystemProvidesFromPath :: String -> IOErr SystemProvides
getSystemProvidesFromPath dir
| null dir = getDefaultSystemProvides
| "http://" `isPrefixOf` dir || "ftp://" `isPrefixOf` dir = do
fc <- getFromURL (dir </> "ghc-provides.txt")
fp <- getFromURL (dir </> "platform-provides.txt")
ft <- getFromURL (dir </> "library-providers.txt")
return (parseSystemProvides fc fp ft)
| otherwise = do
fc <- getFromFile (dir </> "ghc-provides.txt")
fp <- getFromFile (dir </> "platform-provides.txt")
ft <- getFromFile (dir </> "library-providers.txt")
return (parseSystemProvides fc fp ft)
------------------------------------------------------------------------
-- Some extras
--
die :: String -> IO a
die s = do
hPutStrLn stderr $ "cabal2pkg:\n" ++ s
exitWith (ExitFailure 1)
-- Safe wrapper for getEnv
getEnvMaybe :: String -> IO (Maybe String)
getEnvMaybe _name = CE.handle ((const :: a -> CE.SomeException -> a) $ 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 = CE.handle (return . handler) $ do
(inh,outh,errh,pid) <- runInteractiveProcess cmd _args Nothing Nothing
output <- hGetContents outh
outMVar <- newEmptyMVar
_ <- forkIO $ (CE.evaluate (length output) >> putMVar outMVar ())
errput <- hGetContents errh
errMVar <- newEmptyMVar
_ <- forkIO $ (CE.evaluate (length errput) >> putMVar errMVar ())
when (not (null input)) $ hPutStr inh input
takeMVar outMVar
takeMVar errMVar
ex <- CE.catch (waitForProcess pid) ((const :: a -> CE.SomeException -> a) $ 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 (ExitFailure e) = Left (ExitFailure e,"","")
handler e = Left (ExitFailure 1, show e, "")