diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,8 +2,8 @@ This package allows Haskell users to easily acquire entropy for use in critical security applications by calling out to either windows crypto api, unix/linux's -`/dev/urandom`. Hardware RNGs (currently RDRAND, patches welcome) are supported -via the `hardwareRNG` function. +`getrandom` and `/dev/urandom`. Hardware RNGs (currently RDRAND, patches +welcome) are supported via the `hardwareRNG` function. ## Quick Start diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -20,23 +20,26 @@ let mConf = lookupProgram ghcProgram (withPrograms lbi) err = error "Could not determine C compiler" cc = locationPath . programLocation . maybe err id $ mConf - b <- canUseRDRAND cc - let newWithPrograms1 = userSpecifyArgs "gcc" cArgs (withPrograms lbi) - newWithPrograms = userSpecifyArgs "ghc" cArgsHC newWithPrograms1 - lbiNew = if b then (lbi {withPrograms = newWithPrograms }) else lbi + lbiNew <- checkRDRAND cc lbi >>= checkGetrandom cc >>= checkGetentropy cc buildHook simpleUserHooks pd lbiNew uh bf } -cArgs :: [String] -cArgs = ["-DHAVE_RDRAND"] +compileCheck :: FilePath -> String -> String -> String -> IO Bool +compileCheck cc testName message sourceCode = do + withTempDirectory normal "" testName $ \tmpDir -> do + writeFile (tmpDir ++ "/" ++ testName ++ ".c") sourceCode + ec <- myRawSystemExitCode normal cc [tmpDir testName ++ ".c", "-o", tmpDir ++ "/a","-no-hs-main"] + notice normal $ message ++ show (ec == ExitSuccess) + return (ec == ExitSuccess) -cArgsHC :: [String] -cArgsHC = cArgs ++ map ("-optc" ++) cArgs +addOptions :: [String] -> [String] -> LocalBuildInfo -> LocalBuildInfo +addOptions cArgs hsArgs lbi = lbi {withPrograms = newWithPrograms } + where newWithPrograms1 = userSpecifyArgs "gcc" cArgs (withPrograms lbi) + newWithPrograms = userSpecifyArgs "ghc" (hsArgs ++ map ("-optc" ++) cArgs) newWithPrograms1 -canUseRDRAND :: FilePath -> IO Bool -canUseRDRAND cc = do - withTempDirectory normal "" "testRDRAND" $ \tmpDir -> do - writeFile (tmpDir ++ "/testRDRAND.c") +checkRDRAND :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo +checkRDRAND cc lbi = do + b <- compileCheck cc "testRDRAND" "Result of RDRAND Test: " (unlines [ "#include " , "int main() {" , " uint64_t therand;" @@ -46,9 +49,61 @@ , " return (!err);" , "}" ]) - ec <- myRawSystemExitCode normal cc [tmpDir "testRDRAND.c", "-o", tmpDir ++ "/a.o","-c"] - notice normal $ "Result of RDRAND Test: " ++ show (ec == ExitSuccess) - return (ec == ExitSuccess) + return $ if b then addOptions cArgs cArgs lbi else lbi + where cArgs = ["-DHAVE_RDRAND"] + +checkGetrandom :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo +checkGetrandom cc lbi = do + libcGetrandom <- compileCheck cc "testLibcGetrandom" "Result of libc getrandom() Test: " + (unlines [ "#define _GNU_SOURCE" + , "#include " + , "#include " + + , "int main()" + , "{" + , " char tmp;" + , " return getrandom(&tmp, sizeof(tmp), GRND_NONBLOCK) != -1;" + , "}" + ]) + if libcGetrandom then return $ addOptions cArgsLibc cArgsLibc lbi + else do + syscallGetrandom <- compileCheck cc "testSyscallGetrandom" "Result of syscall getrandom() Test: " + (unlines [ "#define _GNU_SOURCE" + , "#include " + , "#include " + , "#include " + , "#include " + , "#include " + + , "static ssize_t getrandom(void* buf, size_t buflen, unsigned int flags)" + , "{" + , " return syscall(SYS_getrandom, buf, buflen, flags);" + , "}" + + , "int main()" + , "{" + , " char tmp;" + , " return getrandom(&tmp, sizeof(tmp), GRND_NONBLOCK) != -1;" + , "}" + ]) + return $ if syscallGetrandom then addOptions cArgs cArgs lbi else lbi + where cArgs = ["-DHAVE_GETRANDOM"] + cArgsLibc = cArgs ++ ["-DHAVE_LIBC_GETRANDOM"] + +checkGetentropy :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo +checkGetentropy cc lbi = do + b <- compileCheck cc "testGetentropy" "Result of getentropy() Test: " + (unlines [ "#define _GNU_SOURCE" + , "#include " + + , "int main()" + , "{" + , " char tmp;" + , " return getentropy(&tmp, sizeof(tmp));" + , "}" + ]) + return $ if b then addOptions cArgs cArgs lbi else lbi + where cArgs = ["-DHAVE_GETENTROPY"] myRawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode #if __GLASGOW_HASKELL__ >= 704 diff --git a/System/EntropyGhcjs.hs b/System/EntropyGhcjs.hs --- a/System/EntropyGhcjs.hs +++ b/System/EntropyGhcjs.hs @@ -26,7 +26,7 @@ -- |Handle for manual resource management newtype CryptHandle = CH Crypto --- | Get random values from the hardward RNG or return Nothing if no +-- | Get random values from the hardware RNG or return Nothing if no -- supported hardware RNG is available. -- -- Not supported on ghcjs. diff --git a/System/EntropyNix.hs b/System/EntropyNix.hs --- a/System/EntropyNix.hs +++ b/System/EntropyNix.hs @@ -16,13 +16,16 @@ , hardwareRandom ) where +import Control.Exception import Control.Monad (liftM, when) import Data.ByteString as B import System.IO.Error (mkIOError, eofErrorType, ioeSetErrorString) +import System.IO.Unsafe import Data.Bits (xor) import Foreign (allocaBytes) import Foreign.Ptr +import Foreign.C.Error import Foreign.C.Types import Data.ByteString.Internal as B @@ -39,8 +42,11 @@ -- |Handle for manual resource management data CryptHandle = CH Fd +#ifdef HAVE_GETRANDOM + | UseGetRandom +#endif --- | Get random values from the hardward RNG or return Nothing if no +-- | Get random values from the hardware RNG or return Nothing if no -- supported hardware RNG is available. -- -- Supported hardware: @@ -50,8 +56,7 @@ #ifdef HAVE_RDRAND hardwareRandom n = do b <- cpuHasRdRand - if b - then Just <$> B.create n (\ptr -> + if b then Just <$> B.create n (\ptr -> do r <- c_get_rand_bytes (castPtr ptr) (fromIntegral n) when (r /= 0) (fail "RDRand failed to gather entropy")) else pure Nothing @@ -61,18 +66,36 @@ -- |Open a `CryptHandle` openHandle :: IO CryptHandle -openHandle = do CH `fmap` nonRDRandHandle - where - nonRDRandHandle :: IO Fd - nonRDRandHandle = openFd source ReadOnly Nothing defaultFileFlags +openHandle = +#ifdef HAVE_GETRANDOM + if systemHasGetRandom then return UseGetRandom else +#endif + fmap CH openRandomFile +openRandomFile :: IO Fd +openRandomFile = do + evaluate ensurePoolInitialized + openFd source ReadOnly Nothing defaultFileFlags + -- |Close the `CryptHandle` closeHandle :: CryptHandle -> IO () closeHandle (CH h) = closeFd h +#ifdef HAVE_GETRANDOM +closeHandle UseGetRandom = return () +#endif -- |Read random data from a `CryptHandle` hGetEntropy :: CryptHandle -> Int -> IO B.ByteString -hGetEntropy (CH h) = fdReadBS h +hGetEntropy (CH h) n = fdReadBS h n +#ifdef HAVE_GETRANDOM +hGetEntropy UseGetRandom n = do + bs <- B.createUptoN n (\ptr -> do + r <- c_entropy_getrandom (castPtr ptr) (fromIntegral n) + return $ if r == 0 then n else 0) + if B.length bs == n then return bs + -- getrandom somehow failed. Fall back on /dev/urandom instead. + else bracket openRandomFile closeFd $ flip fdReadBS n +#endif fdReadBS :: Fd -> Int -> IO B.ByteString fdReadBS fd n = @@ -85,6 +108,28 @@ 0 -> ioError (ioeSetErrorString (mkIOError eofErrorType "fdRead" Nothing Nothing) "EOF") n' -> go buf (cnt - fromIntegral n') go _ _ = error "Impossible! The count of bytes left to read is greater than the request or less than zero!" + +#ifdef HAVE_GETRANDOM +foreign import ccall unsafe "system_has_getrandom" + c_system_has_getrandom :: IO CInt +foreign import ccall safe "entropy_getrandom" + c_entropy_getrandom :: Ptr CUChar -> CSize -> IO CInt + +-- NOINLINE and unsafePerformIO are not totally necessary as getrandom will be +-- consistently either present or not, but it is cheaper not to check multiple +-- times. +systemHasGetRandom :: Bool +{-# NOINLINE systemHasGetRandom #-} +systemHasGetRandom = unsafePerformIO $ fmap (/= 0) c_system_has_getrandom +#endif + +foreign import ccall safe "ensure_pool_initialized" + c_ensure_pool_initialized :: IO CInt + +-- Similarly to systemHasGetRandom, NOINLINE is just an optimization. +ensurePoolInitialized :: CInt +{-# NOINLINE ensurePoolInitialized #-} +ensurePoolInitialized = unsafePerformIO $ throwErrnoIfMinus1 "ensurePoolInitialized" $ c_ensure_pool_initialized #ifdef HAVE_RDRAND foreign import ccall unsafe "cpu_has_rdrand" diff --git a/System/EntropyWindows.hs b/System/EntropyWindows.hs --- a/System/EntropyWindows.hs +++ b/System/EntropyWindows.hs @@ -69,7 +69,7 @@ = CH HCRYPTPROV --- | Get random values from the hardward RNG or return Nothing if no +-- | Get random values from the hardware RNG or return Nothing if no -- supported hardware RNG is available. -- -- Supported hardware: diff --git a/System/EntropyXen.hs b/System/EntropyXen.hs --- a/System/EntropyXen.hs +++ b/System/EntropyXen.hs @@ -13,7 +13,7 @@ , openHandle , hGetEntropy , closeHandle - , hardwardRNG + , hardwareRandom ) where import Control.Monad (liftM, when) @@ -49,7 +49,7 @@ closeHandle :: CryptHandle -> IO () closeHandle UseRdRand = return () --- | Get random values from the hardward RNG or return Nothing if no +-- | Get random values from the hardware RNG or return Nothing if no -- supported hardware RNG is available. -- -- Supported hardware: diff --git a/cbits/getrandom.c b/cbits/getrandom.c new file mode 100644 --- /dev/null +++ b/cbits/getrandom.c @@ -0,0 +1,52 @@ +#ifdef HAVE_GETRANDOM + +#define _GNU_SOURCE +#include + +#ifdef HAVE_LIBC_GETRANDOM +#include +#else + +#include +#include +#include +#include + +#ifndef SYS_getrandom +#define SYS_getrandom __NR_getrandom +#endif + +static ssize_t getrandom(void* buf, size_t buflen, unsigned int flags) +{ + return syscall(SYS_getrandom, buf, buflen, flags); +} + +#endif + +int system_has_getrandom() +{ + char tmp; + return getrandom(&tmp, sizeof(tmp), GRND_NONBLOCK) != -1 || errno != ENOSYS; +} + +// Returns 0 on success, non-zero on failure. +int entropy_getrandom(unsigned char* buf, size_t len) +{ + while (len) { + ssize_t bytes_read = getrandom(buf, len, 0); + + if (bytes_read == -1) { + if (errno != EINTR) + return -1; + else + continue; + } + + len -= bytes_read; + buf += bytes_read; + } + + return 0; +} + +#endif diff --git a/cbits/random_initialized.c b/cbits/random_initialized.c new file mode 100644 --- /dev/null +++ b/cbits/random_initialized.c @@ -0,0 +1,54 @@ +#define _GNU_SOURCE +#include +#include +#include +#include +#include + +#ifdef HAVE_GETENTROPY +static int ensure_pool_initialized_getentropy() +{ + char tmp; + return getentropy(&tmp, sizeof(tmp)); +} +#endif + +// Poll /dev/random to wait for randomness. This is a proxy for the /dev/urandom +// pool being initialized. +static int ensure_pool_initialized_poll() +{ + struct pollfd pfd; + int dev_random = open("/dev/random", O_RDONLY); + if (dev_random == -1) + return -1; + + pfd.fd = dev_random; + pfd.events = POLLIN; + pfd.revents = 0; + + while (1) { + int ret = poll(&pfd, 1, -1); + if (ret < 0 && (errno == EAGAIN || errno == EINTR)) + continue; + if (ret != 1) { + close(dev_random); + errno = EIO; + return -1; + } + + break; + } + + return close(dev_random); +} + +// Returns 0 on success, non-zero on failure. +int ensure_pool_initialized() +{ +#ifdef HAVE_GETENTROPY + if (ensure_pool_initialized_getentropy() == 0) + return 0; +#endif + + return ensure_pool_initialized_poll(); +} diff --git a/entropy.cabal b/entropy.cabal --- a/entropy.cabal +++ b/entropy.cabal @@ -1,5 +1,5 @@ name: entropy -version: 0.4.1.5 +version: 0.4.1.6 description: A mostly platform independent method to obtain cryptographically strong entropy (RDRAND, urandom, CryptAPI, and patches welcome) Users looking for cryptographically strong (number-theoretically @@ -23,7 +23,7 @@ cabal-version: >=1.10 tested-with: GHC == 8.2.2 -- data-files: -extra-source-files: ./cbits/rdrand.c, ./cbits/rdrand.h, README.md +extra-source-files: ./cbits/getrandom.c ./cbits/random_initialized.c ./cbits/rdrand.c, ./cbits/rdrand.h, README.md -- Notice to compile with HaLVM the above 'build-type' must be changed -- to 'Simple' instead of 'Custom'. The current build system naively @@ -34,7 +34,7 @@ custom-setup - setup-depends: Cabal >= 1.10 && < 3.1 + setup-depends: Cabal >= 1.10 && < 3.3 , base < 5 , filepath < 1.5 , directory < 1.4 @@ -43,7 +43,7 @@ library ghc-options: -O2 exposed-modules: System.Entropy - if impl(ghcjs) + if impl(ghcjs) || os(ghcjs) other-modules: System.EntropyGhcjs else { if os(windows) @@ -60,8 +60,8 @@ build-depends: base >= 4.8 && < 5, bytestring default-language: Haskell2010 - - if impl(ghcjs) { + + if impl(ghcjs) || os(ghcjs) { build-depends: ghcjs-dom , jsaddle } @@ -86,6 +86,7 @@ else if !os(halvm) Build-Depends: unix + c-sources: cbits/getrandom.c cbits/random_initialized.c }