Debugging http://spaceport.io/community/forum/forums/1/topics/59

test_java.hs

-- ghc -Wall -Werror -O2 test_java.hs -o test_java.exe && strip test_java.exe

import Control.Applicative
import Control.Monad (guard)
import Data.Bits
import Data.List (nub)
import Data.Maybe (catMaybes)
import System.Exit
import System.FilePath
import System.IO
import System.IO.Error
import System.Process

import qualified Control.Exception as Ex
import qualified GHC.IO.Exception
import qualified System.Win32.Registry as Reg
import qualified System.Win32.Types as Reg (HKEY)

tryThis :: String -> IO () -> IO ()
tryThis message m = do
    putStrLn $ "Trying " ++ message ++ "..."
    (m >> putStrLn "OK") `Ex.catch` onException
    putStrLn ""
    where
        onException :: Ex.SomeException -> IO ()
        onException e = putStrLn $ "Failed: " ++ show e

hPipe :: Handle -> Handle -> IO ()
hPipe inp out = hGetContents inp >>= hPutStr out

checkExitCode :: ExitCode -> IO ()
checkExitCode ExitSuccess = return ()
checkExitCode exitCode@(ExitFailure _) = Ex.throw exitCode

dealWithHandles :: (Handle, Handle, Handle, ProcessHandle) -> IO ()
dealWithHandles (inp, out, err, pid) = do
    hClose inp
    hPipe out stdout
    hPipe err stdout
    checkExitCode =<< waitForProcess pid

registryLocations :: [String]
registryLocations =
    [ "SOFTWARE\\JavaSoft\\Java Runtime Environment" 
    , "SOFTWARE\\Wow6432Node\\JavaSoft\\Java Runtime Environment"
    ]

findJRERootKeysWithRegsam :: Reg.REGSAM -> IO [Reg.HKEY]
findJRERootKeysWithRegsam regsam
    = fmap catMaybes . flip mapM registryLocations $ \ loc -> ignoreKeyNotFound
        $ Just <$> Reg.regOpenKeyEx Reg.hKEY_LOCAL_MACHINE loc (regsam .|. Reg.kEY_READ)

-- We look in all the registries we can find: current, 32-bit, 64-bit.
findJRERootKeys :: IO [(Reg.HKEY, Reg.REGSAM)]
findJRERootKeys
    = concat <$> mapM findWithRegsam regsams
    where
        regsams = [0, kEY_WOW64_64KEY, kEY_WOW64_32KEY]
        kEY_WOW64_64KEY = 0x0100
        kEY_WOW64_32KEY = 0x0200
        findWithRegsam regsam = do
            keys <- findJRERootKeysWithRegsam regsam
            return $ map (\ key -> (key, regsam)) keys

findJREInstallation :: Reg.HKEY -> Reg.REGSAM -> IO (Maybe FilePath)
findJREInstallation root regsamAdd = do
    currentVersion <- Reg.regQueryValue root (Just "CurrentVersion")
    key <- Reg.regOpenKeyEx root currentVersion regsam
    fmap Just $ Reg.regQueryValue key (Just "JavaHome")
    where regsam = Reg.kEY_READ .|. regsamAdd

ignoreKeyNotFound :: (Alternative f) => IO (f a) -> IO (f a)
ignoreKeyNotFound = Ex.handleJust
    (guard . isKeyNotFound)
    (const $ return empty)
    where
        isKeyNotFound err
            = ioeGetErrorType err == GHC.IO.Exception.InvalidArgument

findJREInstallations :: IO [FilePath]
findJREInstallations = fmap (nub . catMaybes)
    $ mapM (uncurry findJREInstallation) =<< findJRERootKeys

getJVMPath :: IO FilePath
getJVMPath = do
    installations <- findJREInstallations
    case installations of
        -- TODO Find first existing.
        (x:_) -> return (x </> "bin" </> "java.exe")
        [] -> fail "No JRE installation found"

main :: IO ()
main = do
    java <- getJVMPath

    tryThis "runInteractiveProcess java -version" $ do
        dealWithHandles =<< runInteractiveProcess
            "java" ["-version"] Nothing Nothing

    tryThis "runInteractiveProcess java.exe -version" $ do
        dealWithHandles =<< runInteractiveProcess
            "java.exe" ["-version"] Nothing Nothing

    tryThis ("runInteractiveProcess " ++ java ++ " -version") $ do
        dealWithHandles =<< runInteractiveProcess
            java ["-version"] Nothing Nothing