Don't use stdout to communicate arguments (#90)

* Don't use stdout to communicate arguments

Now all the cradles communicate by reading the value of `HIE_BIOS_OUTPUT`
which is a `FilePath`, and writing the arguments to that temporary file.
This makes all the cradles more robust about the build tools spurting
things to stdout.

* Review comments

* Filter out '\r' characters from stdout/stderr streams for windows

* Filter out \r characters from response file as well

* Add --no-nix-pure

Author: mpickering

README.md

@@ -49,7 +49,10 @@ cradle: {cabal: {component: "lib:haskell-ide-engine"}}
 Or you can explicitly state the program which should be used to collect
 the options by supplying the path to the program. It is interpreted
 relative to the current working directory if it is not an absolute path.
-The bios program should return a list of options separated by newline characters.
+The bios program should consult the `HIE_BIOS_OUTPUT` env var and write a list of
+options to this file separated by newlines. Once the program finishes running `hie-bios`
+reads this file and uses the arguments to set up the GHC session. This is how GHC's
+build system is able to support `hie-bios`.
 
 ```yaml
 cradle: {bios: {program: ".hie-bios"}}

hie-bios.cabal

@@ -37,6 +37,7 @@ Library
                         HIE.Bios.Ghc.Gap
                         HIE.Bios.Ghc.Load
                         HIE.Bios.Ghc.Logger
+                        HIE.Bios.Wrappers
   Other-Modules:        Paths_hie_bios
   Build-Depends:
                         base >= 4.8 && < 5,
@@ -50,7 +51,6 @@ Library
                         time                 >= 1.8.0 && < 1.10,
                         extra                >= 1.6.14 && < 1.7,
                         process              >= 1.6.1 && < 1.7,
-                        file-embed           >= 0.0.10 && < 0.1,
                         ghc                  >= 8.2.2 && < 8.9,
                         transformers         >= 0.5.2 && < 0.6,
                         temporary            >= 1.2 && < 1.4,
@@ -59,7 +59,10 @@ Library
                         unordered-containers >= 0.2.9 && < 0.3,
                         vector               >= 0.12.0 && < 0.13,
                         yaml                 >= 0.8.32 && < 0.12,
-                        hslogger             >= 1.2 && < 1.4
+                        hslogger             >= 1.2 && < 1.4,
+                        file-embed           >= 0.0.11 && < 1,
+                        conduit              >= 1.3 && < 2,
+                        conduit-extra        >= 1.3 && < 2
 
 
 Executable hie-bios

src/HIE/Bios/Cradle.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE BangPatterns #-}
 module HIE.Bios.Cradle (
       findCradle
     , loadCradle
@@ -15,18 +15,26 @@ import System.Directory hiding (findFile)
 import Control.Monad.Trans.Maybe
 import System.FilePath
 import Control.Monad
-import Control.Monad.IO.Class
 import System.Info.Extra
+import Control.Monad.IO.Class
+import System.Environment
 import Control.Applicative ((<|>))
-import Data.FileEmbed
 import System.IO.Temp
 import Data.List
 import Data.Ord (Down(..))
 
 import System.PosixCompat.Files
+import HIE.Bios.Wrappers
+import System.IO
+import Control.DeepSeq
 
 import Data.Version (showVersion)
 import Paths_hie_bios
+import Data.Conduit.Process
+import qualified Data.Conduit.Combinators as C
+import qualified Data.Conduit as C
+import qualified Data.Conduit.Text as C
+import Data.Text (unpack)
 ----------------------------------------------------------------
 
 -- | Given root\/foo\/bar.hs, return root\/hie.yaml, or wherever the yaml file was found.
@@ -81,9 +89,9 @@ addCradleDeps deps c =
   where
     addActionDeps :: CradleAction -> CradleAction
     addActionDeps ca =
-      ca { runCradle = \fp ->
+      ca { runCradle = \l fp ->
             (fmap (\(ComponentOptions os' ds) -> ComponentOptions os' (ds `union` deps)))
-              <$> runCradle ca fp }
+              <$> runCradle ca l fp }
 
 implicitConfig :: FilePath -> MaybeT IO (CradleConfig, FilePath)
 implicitConfig fp = do
@@ -125,7 +133,7 @@ defaultCradle cur_dir =
     { cradleRootDir = cur_dir
     , cradleOptsProg = CradleAction
         { actionName = "default"
-        , runCradle = const $ return (CradleSuccess (ComponentOptions [] []))
+        , runCradle = \_ _ -> return (CradleSuccess (ComponentOptions [] []))
         }
     }
 
@@ -138,7 +146,7 @@ noneCradle cur_dir =
     { cradleRootDir = cur_dir
     , cradleOptsProg = CradleAction
         { actionName = "none"
-        , runCradle = const $ return CradleNone
+        , runCradle = \_ _ -> return CradleNone
         }
     }
 
@@ -151,18 +159,19 @@ multiCradle cur_dir cs =
     { cradleRootDir = cur_dir
     , cradleOptsProg = CradleAction
         { actionName = "multi"
-        , runCradle = canonicalizePath >=> multiAction cur_dir cs
+        , runCradle = \l fp -> canonicalizePath fp >>= multiAction cur_dir cs l
         }
     }
 
 multiAction :: FilePath
             -> [(FilePath, CradleConfig)]
+            -> LoggingFunction
             -> FilePath
             -> IO (CradleLoadResult ComponentOptions)
-multiAction cur_dir cs cur_fp = selectCradle =<< canonicalizeCradles
+multiAction cur_dir cs l cur_fp = selectCradle =<< canonicalizeCradles
 
   where
-    err_msg = unlines $ ["Multi Cradle: No prefixes matched"
+    err_msg = ["Multi Cradle: No prefixes matched"
                       , "pwd: " ++ cur_dir
                       , "filepath" ++ cur_fp
                       , "prefixes:"
@@ -180,7 +189,7 @@ multiAction cur_dir cs cur_fp = selectCradle =<< canonicalizeCradles
       return (CradleFail (CradleError ExitSuccess err_msg))
     selectCradle ((p, c): css) =
         if p `isPrefixOf` cur_fp
-          then runCradle (cradleOptsProg (getCradle (c, cur_dir))) cur_fp
+          then runCradle (cradleOptsProg (getCradle (c, cur_dir))) l cur_fp
           else selectCradle css
 
 
@@ -192,7 +201,7 @@ directCradle wdir args  =
     { cradleRootDir = wdir
     , cradleOptsProg = CradleAction
         { actionName = "direct"
-        , runCradle = const $ return (CradleSuccess (ComponentOptions args []))
+        , runCradle = \_ _ -> return (CradleSuccess (ComponentOptions args []))
         }
     }
 
@@ -214,28 +223,30 @@ biosCradle wdir biosProg biosDepsProg =
 biosWorkDir :: FilePath -> MaybeT IO FilePath
 biosWorkDir = findFileUpwards (".hie-bios" ==)
 
-biosDepsAction :: Maybe FilePath -> IO [FilePath]
-biosDepsAction (Just biosDepsProg) = do
+biosDepsAction :: LoggingFunction -> FilePath -> Maybe FilePath -> IO [FilePath]
+biosDepsAction l wdir (Just biosDepsProg) = do
   biosDeps' <- canonicalizePath biosDepsProg
-  (ex, sout, serr) <- readProcessWithExitCode biosDeps' [] []
+  (ex, sout, serr, args) <- readProcessWithOutputFile l wdir biosDeps' []
   case ex of
     ExitFailure _ ->  error $ show (ex, sout, serr)
-    ExitSuccess -> return (lines sout)
-biosDepsAction Nothing = return []
+    ExitSuccess -> return args
+biosDepsAction _ _ Nothing = return []
 
 biosAction :: FilePath
            -> FilePath
            -> Maybe FilePath
+           -> LoggingFunction
            -> FilePath
            -> IO (CradleLoadResult ComponentOptions)
-biosAction _wdir bios bios_deps fp = do
+biosAction wdir bios bios_deps l fp = do
   bios' <- canonicalizePath bios
-  (ex, res, std) <- readProcessWithExitCode bios' [fp] []
-  deps <- biosDepsAction bios_deps
-        -- Output from the program should be delimited by newlines.
+  (ex, _stdo, std, res) <- readProcessWithOutputFile l wdir bios' [fp]
+  deps <- biosDepsAction l wdir bios_deps
+        -- Output from the program should be written to the output file and
+        -- delimited by newlines.
         -- Execute the bios action and add dependencies of the cradle.
         -- Removes all duplicates.
-  return $ makeCradleResult (ex, std, lines res) deps
+  return $ makeCradleResult (ex, std, res) deps
 
 ------------------------------------------------------------------------
 -- Cabal Cradle
@@ -262,31 +273,18 @@ findCabalFiles wdir = do
   dirContent <- listDirectory wdir
   return $ filter ((== ".cabal") . takeExtension) dirContent
 
-cabalWrapper :: String
-cabalWrapper = $(embedStringFile "wrappers/cabal")
 
-cabalWrapperHs :: String
-cabalWrapperHs = $(embedStringFile "wrappers/cabal.hs")
-
-processCabalWrapperArgs :: String -> Maybe [String]
+processCabalWrapperArgs :: [String] -> Maybe [String]
 processCabalWrapperArgs args =
-    case lines args of
-        [dir, ghc_args] ->
+    case args of
+        (dir: ghc_args) ->
             let final_args =
                     removeVerbosityOpts
                     $ removeInteractive
                     $ map (fixImportDirs dir)
-                    $ limited ghc_args
+                    $ ghc_args
             in Just final_args
         _ -> Nothing
-  where
-    limited :: String -> [String]
-    limited = unfoldr $ \argstr ->
-        if null argstr
-        then Nothing
-        else
-            let (arg, argstr') = break (== '\NUL') argstr
-            in Just (arg, drop 1 argstr')
 
 -- generate a fake GHC that can be passed to cabal
 -- when run with --interactive, it will print out its
@@ -315,20 +313,20 @@ getCabalWrapperTool = do
   _check <- readFile wrapper_fp
   return wrapper_fp
 
-cabalAction :: FilePath -> Maybe String -> FilePath -> IO (CradleLoadResult ComponentOptions)
-cabalAction work_dir mc _fp = do
+cabalAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)
+cabalAction work_dir mc l _fp = do
   wrapper_fp <- getCabalWrapperTool
-  let cab_args = ["v2-repl", "-v0", "--disable-documentation", "--with-compiler", wrapper_fp]
+  let cab_args = ["v2-repl", "--with-compiler", wrapper_fp]
                   ++ [component_name | Just component_name <- [mc]]
-  (ex, args, stde) <-
-    readProcessWithExitCodeInDirectory work_dir "cabal" cab_args []
-
+  (ex, output, stde, args) <-
+    readProcessWithOutputFile l work_dir "cabal" cab_args
   deps <- cabalCradleDependencies work_dir
   case processCabalWrapperArgs args of
       Nothing -> pure $ CradleFail (CradleError ex
-                  (unlines ["Failed to parse result of calling cabal"
-                           , stde
-                           , args]))
+                  ["Failed to parse result of calling cabal"
+                   , unlines output
+                   , unlines stde
+                   , unlines args])
       Just final_args -> pure $ makeCradleResult (ex, stde, final_args) deps
 
 removeInteractive :: [String] -> [String]
@@ -367,25 +365,25 @@ stackCradle wdir =
 
 stackCradleDependencies :: FilePath -> IO [FilePath]
 stackCradleDependencies wdir = do
-    cabalFiles <- findCabalFiles wdir
-    return $ cabalFiles ++ ["package.yaml", "stack.yaml"]
+  cabalFiles <- findCabalFiles wdir
+  return $ cabalFiles ++ ["package.yaml", "stack.yaml"]
 
-stackAction :: FilePath -> FilePath -> IO (CradleLoadResult ComponentOptions)
-stackAction work_dir fp = do
+stackAction :: FilePath -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)
+stackAction work_dir l fp = do
   -- Same wrapper works as with cabal
   wrapper_fp <- getCabalWrapperTool
-  (ex1, args, stde) <-
-      readProcessWithExitCodeInDirectory work_dir "stack" ["repl", "--silent", "--no-load", "--with-ghc", wrapper_fp, fp ] []
-  (ex2, pkg_args, stdr) <-
-      readProcessWithExitCodeInDirectory work_dir "stack" ["path", "--ghc-package-path"] []
-  let split_pkgs = splitSearchPath (init pkg_args)
+  (ex1, _stdo, stde, args) <-
+      readProcessWithOutputFile l work_dir "stack" ["repl", "--no-nix-pure", "--no-load", "--with-ghc", wrapper_fp, fp ]
+  (ex2, pkg_args, stdr, _) <-
+    readProcessWithOutputFile l work_dir "stack" ["path", "--ghc-package-path"]
+  let split_pkgs = concatMap splitSearchPath pkg_args
       pkg_ghc_args = concatMap (\p -> ["-package-db", p] ) split_pkgs
   deps <- stackCradleDependencies work_dir
   return $ case processCabalWrapperArgs args of
-      Nothing -> CradleFail (CradleError ex1
-                  (unlines ["Failed to parse result of calling cabal"
-                           , stde
-                           , args]))
+      Nothing -> CradleFail (CradleError ex1 $
+                  ("Failed to parse result of calling cabal":
+                    stde)
+                   ++ args)
 
       Just ghc_args -> makeCradleResult (combineExitCodes [ex1, ex2], stde ++ stdr, ghc_args ++ pkg_ghc_args) deps
 
@@ -435,7 +433,7 @@ rulesHaskellAction work_dir fp = do
   setFileMode wrapper_fp accessModes
   let rel_path = makeRelative work_dir fp
   (ex, args, stde) <-
-      readProcessWithExitCodeInDirectory work_dir wrapper_fp [rel_path] []
+      readProcessWithOutputFile work_dir wrapper_fp [rel_path] []
   let args'  = filter (/= '\'') args
   let args'' = filter (/= "\"$GHCI_LOCATION\"") (words args')
   deps <- rulesHaskellCradleDependencies work_dir
@@ -471,7 +469,7 @@ obeliskCradle wdir =
 obeliskAction :: FilePath -> FilePath -> IO (CradleLoadResult ComponentOptions)
 obeliskAction work_dir _fp = do
   (ex, args, stde) <-
-      readProcessWithExitCodeInDirectory work_dir "ob" ["ide-args"] []
+      readProcessWithOutputFile work_dir "ob" ["ide-args"] []
 
   o_deps <- obeliskCradleDependencies work_dir
   return (makeCradleResult (ex, stde, words args) o_deps )
@@ -502,15 +500,34 @@ findFile p dir = do
     getFiles = filter p <$> getDirectoryContents dir
     doesPredFileExist file = doesFileExist $ dir </> file
 
--- | Call a process with the given arguments and the given stdin
--- in the given working directory.
-readProcessWithExitCodeInDirectory
-  :: FilePath -> FilePath -> [String] -> String -> IO (ExitCode, String, String)
-readProcessWithExitCodeInDirectory work_dir fp args stdin =
-  let process = (proc fp args) { cwd = Just work_dir }
-  in  readCreateProcessWithExitCode process stdin
-
-makeCradleResult :: (ExitCode, String, [String]) -> [FilePath] -> CradleLoadResult ComponentOptions
+-- | Call a process with the given arguments
+-- * A special file is created for the process to write to, the process can discover the name of
+-- the file by reading the @HIE_BIOS_OUTPUT@ environment variable. The contents of this file is
+-- returned by the function.
+-- * The logging function is called every time the process emits anything to stdout or stderr.
+-- it can be used to report progress of the process to a user.
+-- * The process is executed in the given directory
+readProcessWithOutputFile
+  :: LoggingFunction
+  -> FilePath
+  -> FilePath
+  -> [String]
+  -> IO (ExitCode, [String], [String], [String])
+readProcessWithOutputFile l work_dir fp args = withSystemTempFile "bios-output" $ \output_file h -> do
+  hSetBuffering h LineBuffering
+  old_env <- getEnvironment
+  -- Pipe stdout directly into the logger
+  let process = (proc fp args) { cwd = Just work_dir
+                               , env = Just (("HIE_BIOS_OUTPUT", output_file) : old_env)
+                               }
+      -- Windows line endings are not converted so you have to filter out `'r` characters
+      loggingConduit = (C.decodeUtf8  C..| C.lines C..| C.filterE (/= '\r')  C..| C.map unpack C..| C.iterM l C..| C.sinkList)
+  (ex, stdo, stde) <- sourceProcessWithStreams process mempty loggingConduit loggingConduit
+  !res <- force <$> hGetContents h
+  return (ex, stdo, stde, lines (filter (/= '\r') res))
+
+
+makeCradleResult :: (ExitCode, [String], [String]) -> [FilePath] -> CradleLoadResult ComponentOptions
 makeCradleResult (ex, err, gopts) deps =
   case ex of
     ExitFailure _ -> CradleFail (CradleError ex err)

src/HIE/Bios/Flags.hs

@@ -1,6 +1,7 @@
 module HIE.Bios.Flags (getCompilerOptions) where
 
 import HIE.Bios.Types
+import HIE.Bios.Internal.Log
 
 
 -- | Initialize the 'DynFlags' relating to the compilation of a single
@@ -10,7 +11,7 @@ getCompilerOptions ::
     -> Cradle
     -> IO (CradleLoadResult ComponentOptions)
 getCompilerOptions fp cradle =
-  runCradle (cradleOptsProg cradle) fp
+  runCradle (cradleOptsProg cradle) logm fp
 
 
 ----------------------------------------------------------------

src/HIE/Bios/Internal/Debug.hs

@@ -7,6 +7,7 @@ import Data.Maybe (fromMaybe)
 
 import HIE.Bios.Ghc.Api
 import HIE.Bios.Types
+import HIE.Bios.Flags
 
 ----------------------------------------------------------------
 
@@ -21,7 +22,7 @@ import HIE.Bios.Types
 debugInfo :: Cradle
           -> IO String
 debugInfo cradle = unlines <$> do
-    res <- runCradle (cradleOptsProg cradle) (cradleRootDir cradle)
+    res <- getCompilerOptions (cradleRootDir cradle) cradle
     case res of
       CradleSuccess (ComponentOptions gopts deps) -> do
         mglibdir <- liftIO getSystemLibDir
@@ -34,7 +35,7 @@ debugInfo cradle = unlines <$> do
       CradleFail (CradleError ext stderr) ->
         return ["Cradle failed to load"
                , "Exit Code: " ++ show ext
-               , "Stderr: " ++ stderr]
+               , "Stderr: " ++ unlines stderr]
       CradleNone ->
         return ["No cradle"]
   where