System.hs

-- | Haskell implementations of hydra.lib.system primitives

module Hydra.Overlay.Haskell.Lib.System where

import qualified Control.Exception as E
import qualified Data.ByteString as BS
import qualified Data.Map as M
import qualified Data.Maybe as Y
import qualified Hydra.Error.System as SystemError
import qualified Hydra.File as File
import qualified Hydra.System as System
import qualified Hydra.Time as Time
import Data.Time.Clock.POSIX (getPOSIXTime)
import System.Exit (ExitCode(..), exitWith)
import qualified System.Directory as Dir
import qualified System.Environment as Env
import qualified System.IO as SIO
import qualified System.IO.Error as IOE
import qualified System.Process as P


-- | Run a program to completion and capture its result.
execute :: System.Command -> IO (Either SystemError.SystemError System.ProcessResult)
execute command =
  let program = File.unFilePath (System.commandProgram command)
      args = System.commandArguments command
      cwd = fmap File.unFilePath (System.commandWorkingDirectory command)
      env = fmap toEnvList (System.commandEnvironment command)
      proc0 = (P.proc program args) {
                P.cwd = cwd,
                P.env = env,
                P.std_out = P.CreatePipe,
                P.std_err = P.CreatePipe}
  in E.catch (runProcess proc0) (pure . Left . classify (System.commandProgram command))

-- | Terminate the current process with a status code.
exit :: System.StatusCode -> IO ()
exit code =
  let n = System.unStatusCode code
  in exitWith (if n == 0 then ExitSuccess else ExitFailure (fromIntegral n))

-- | Get the full set of environment variables.
getEnvironment :: IO (M.Map System.EnvironmentVariable String)
getEnvironment = do
  pairs <- Env.getEnvironment
  pure $ M.fromList [(System.EnvironmentVariable k, v) | (k, v) <- pairs]

-- | Look up a single environment variable by name.
getEnvironmentVariable :: System.EnvironmentVariable -> IO (Maybe String)
getEnvironmentVariable name =
  Env.lookupEnv (System.unEnvironmentVariable name)

-- | Get the current wall-clock time.
getTime :: IO Time.Timespec
getTime = do
  t <- getPOSIXTime
  let picos = floor (toRational t * 1000000000000) :: Integer
      (secs, subPicos) = picos `divMod` 1000000000000
      nanos = subPicos `div` 1000
  pure Time.Timespec {
    Time.timespecSeconds = fromInteger secs,
    Time.timespecNanoseconds = fromInteger nanos}

-- | Get the current working directory.
getWorkingDirectory :: IO (Either SystemError.SystemError File.FilePath)
getWorkingDirectory =
  E.catch (Right . File.FilePath <$> Dir.getCurrentDirectory)
    (\e -> pure $ Left $ SystemError.SystemErrorOther (IOE.ioeGetErrorString (e :: IOError)))

-- | Read the complete contents of standard input as raw bytes.
readStdin :: IO (Either SystemError.SystemError BS.ByteString)
readStdin = withStdioError BS.hGetContents SIO.stdin

-- | Write raw bytes to standard error.
writeStderr :: BS.ByteString -> IO (Either SystemError.SystemError ())
writeStderr = withStdioError' BS.hPut SIO.stderr

-- | Write raw bytes to standard output.
writeStdout :: BS.ByteString -> IO (Either SystemError.SystemError ())
writeStdout = withStdioError' BS.hPut SIO.stdout

-- Helpers (not primitives)

withStdioError :: (SIO.Handle -> IO a) -> SIO.Handle -> IO (Either SystemError.SystemError a)
withStdioError action handle =
  E.catch (Right <$> action handle)
    (\e -> pure $ Left $ SystemError.SystemErrorOther (IOE.ioeGetErrorString (e :: IOError)))

withStdioError' :: (SIO.Handle -> a -> IO ()) -> SIO.Handle -> a -> IO (Either SystemError.SystemError ())
withStdioError' action handle x = withStdioError (`action` x) handle

-- | Convert the environment map to the association list System.Process expects.
toEnvList :: M.Map System.EnvironmentVariable String -> [(String, String)]
toEnvList m = [(System.unEnvironmentVariable k, v) | (k, v) <- M.toList m]

-- | Run a prepared process, capturing stdout/stderr as bytes and the exit code.
runProcess :: P.CreateProcess -> IO (Either SystemError.SystemError System.ProcessResult)
runProcess cp = do
  (_, mout, merr, ph) <- P.createProcess cp
  out <- Y.maybe (pure BS.empty) BS.hGetContents mout
  err <- Y.maybe (pure BS.empty) BS.hGetContents merr
  ec <- P.waitForProcess ph
  let code = case ec of
        ExitSuccess -> 0
        ExitFailure n -> fromIntegral n
  pure $ Right System.ProcessResult {
    System.processResultExitCode = System.StatusCode code,
    System.processResultStdout = out,
    System.processResultStderr = err}

-- | Classify a launch IOError into a SystemError.
classify :: File.FilePath -> IOError -> SystemError.SystemError
classify program e
  | IOE.isDoesNotExistError e = SystemError.SystemErrorCommandNotFound program
  | IOE.isPermissionError e = SystemError.SystemErrorPermissionDenied program
  | otherwise = SystemError.SystemErrorOther (IOE.ioeGetErrorString e)