1{-# LANGUAGE CPP #-}
2import Control.Monad
3import Distribution.Simple
4import Distribution.Simple.LocalBuildInfo
5import Distribution.Simple.Setup
6import Distribution.PackageDescription
7import Distribution.Simple.Utils
8import Distribution.Simple.Program
9import Distribution.Verbosity
10import System.Process
11import System.Directory
12import System.FilePath
13import System.Exit
14import System.IO
15
16main = defaultMainWithHooks hk
17 where
18 hk = simpleUserHooks { buildHook = \pd lbi uh bf -> do
19                                        -- let ccProg = Program "gcc" undefined undefined undefined
20                                        let mConf  = lookupProgram ghcProgram (withPrograms lbi)
21                                            err    = error "Could not determine C compiler"
22                                            cc     = locationPath . programLocation  . maybe err id $ mConf
23                                        lbiNew <- checkRDRAND cc lbi >>= checkGetrandom cc >>= checkGetentropy cc
24                                        buildHook simpleUserHooks pd lbiNew uh bf
25                      }
26
27compileCheck :: FilePath -> String -> String -> String -> IO Bool
28compileCheck cc testName message sourceCode = do
29        withTempDirectory normal "" testName $ \tmpDir -> do
30        writeFile (tmpDir ++ "/" ++ testName ++ ".c") sourceCode
31        ec <- myRawSystemExitCode normal cc [tmpDir </> testName ++ ".c", "-o", tmpDir ++ "/a","-no-hs-main"]
32        notice normal $ message ++ show (ec == ExitSuccess)
33        return (ec == ExitSuccess)
34
35addOptions :: [String] -> [String] -> LocalBuildInfo -> LocalBuildInfo
36addOptions cArgs hsArgs lbi = lbi {withPrograms = newWithPrograms }
37  where newWithPrograms1 = userSpecifyArgs "gcc" cArgs (withPrograms lbi)
38        newWithPrograms  = userSpecifyArgs "ghc" (hsArgs ++ map ("-optc" ++) cArgs) newWithPrograms1
39
40checkRDRAND :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo
41checkRDRAND cc lbi = do
42        b <- compileCheck cc "testRDRAND" "Result of RDRAND Test: "
43                (unlines        [ "#include <stdint.h>"
44                                , "int main() {"
45                                , "   uint64_t therand;"
46                                , "   unsigned char err;"
47                                , "   asm volatile(\"rdrand %0 ; setc %1\""
48                                , "     : \"=r\" (therand), \"=qm\" (err));"
49                                , "   return (!err);"
50                                , "}"
51                                ])
52        return $ if b then addOptions cArgs cArgs lbi else lbi
53  where cArgs = ["-DHAVE_RDRAND"]
54
55checkGetrandom :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo
56checkGetrandom cc lbi = do
57        libcGetrandom <- compileCheck cc "testLibcGetrandom" "Result of libc getrandom() Test: "
58                (unlines        [ "#define _GNU_SOURCE"
59                                , "#include <errno.h>"
60                                , "#include <sys/random.h>"
61
62                                , "int main()"
63                                , "{"
64                                , "    char tmp;"
65                                , "    return getrandom(&tmp, sizeof(tmp), GRND_NONBLOCK) != -1;"
66                                , "}"
67                                ])
68        if libcGetrandom then return $ addOptions cArgsLibc cArgsLibc lbi
69        else do
70        syscallGetrandom <- compileCheck cc "testSyscallGetrandom" "Result of syscall getrandom() Test: "
71                (unlines        [ "#define _GNU_SOURCE"
72                                , "#include <errno.h>"
73                                , "#include <unistd.h>"
74                                , "#include <sys/syscall.h>"
75                                , "#include <sys/types.h>"
76                                , "#include <linux/random.h>"
77
78                                , "static ssize_t getrandom(void* buf, size_t buflen, unsigned int flags)"
79                                , "{"
80                                , "    return syscall(SYS_getrandom, buf, buflen, flags);"
81                                , "}"
82
83                                , "int main()"
84                                , "{"
85                                , "    char tmp;"
86                                , "    return getrandom(&tmp, sizeof(tmp), GRND_NONBLOCK) != -1;"
87                                , "}"
88                                ])
89        return $ if syscallGetrandom then addOptions cArgs cArgs lbi else lbi
90  where cArgs = ["-DHAVE_GETRANDOM"]
91        cArgsLibc = cArgs ++ ["-DHAVE_LIBC_GETRANDOM"]
92
93checkGetentropy :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo
94checkGetentropy cc lbi = do
95        b <- compileCheck cc "testGetentropy" "Result of getentropy() Test: "
96                (unlines        [ "#define _GNU_SOURCE"
97                                , "#include <unistd.h>"
98
99                                , "int main()"
100                                , "{"
101                                , "    char tmp;"
102                                , "    return getentropy(&tmp, sizeof(tmp));"
103                                , "}"
104                                ])
105        return $ if b then addOptions cArgs cArgs lbi else lbi
106  where cArgs = ["-DHAVE_GETENTROPY"]
107
108myRawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode
109#if __GLASGOW_HASKELL__ >= 704
110-- We know for sure, that if GHC >= 7.4 implies Cabal >= 1.14
111myRawSystemExitCode = rawSystemExitCode
112#else
113-- Legacy branch:
114-- We implement our own 'rawSystemExitCode', this will even work if
115-- the user happens to have Cabal >= 1.14 installed with GHC 7.0 or
116-- 7.2
117myRawSystemExitCode verbosity path args = do
118    printRawCommandAndArgs verbosity path args
119    hFlush stdout
120    exitcode <- rawSystem path args
121    unless (exitcode == ExitSuccess) $ do
122        debug verbosity $ path ++ " returned " ++ show exitcode
123    return exitcode
124  where
125    printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
126    printRawCommandAndArgs verbosity path args
127      | verbosity >= deafening = print (path, args)
128      | verbosity >= verbose = putStrLn $ unwords (path : args)
129      | otherwise = return ()
130#endif
131