{-# OPTIONS_GHC -O0 #-}

{- |
    The ghcjs-boot program installs the libraries and runtime system for GHCJS

    You can explicitly set the boot source location with the -s option. It
    can either be a directory containing the boot.yaml file or a boot.tar
    archive.

    if the -s option is not set, the following locations are tried in order:

      1. the current directory if it contains boot.yaml
      2. the boot.tar file installed by cabal install in the GHCJS
         data directory

    ghcjs-boot installs the libraries into the GHCJS library directory,
    which is set by the `ghcjs' and `ghcjs-pkg' scripts, which pass the
    library path with the -B option to the underlying binary executable.

    modify the scripts to change the installation location
 -}

{-# LANGUAGE ExtendedDefaultRules,
             OverloadedStrings,
             ScopedTypeVariables,
             TemplateHaskell,
             LambdaCase,
             FlexibleInstances,
             DeriveDataTypeable,
             GeneralizedNewtypeDeriving,
             NoMonomorphismRestriction,
             FlexibleContexts,
             RankNTypes,
             TupleSections
  #-}
module Main (main) where

import           Prelude
  hiding (elem, mapM, mapM_, any, all, concat, concatMap)

-- import qualified Prelude

import qualified Distribution.Simple.Utils       as Cabal
import qualified Distribution.Verbosity          as Cabal


import qualified Codec.Archive.Tar               as Tar
import qualified Codec.Archive.Tar.Entry         as Tar

import           Control.Applicative
import qualified Control.Exception               as Ex
import           Control.Lens                    hiding ((<.>))
import           Control.Monad.Reader            (MonadReader, ReaderT(..), ask )
import           Control.Monad.State

import qualified Data.Aeson                      as Aeson
import qualified Data.ByteString                 as B
import qualified Data.ByteString.Lazy            as BL
import           Data.Data
import           Data.Data.Lens
import           Data.Foldable
import qualified Data.HashMap.Strict             as HM
import           Data.List                       (intercalate, transpose)
import           Data.Maybe
import           Data.Text                       (Text)
import qualified Data.Text                       as T
import qualified Data.Text.IO                    as T
import qualified Data.Vector                     as V
import           Data.Yaml                       ((.:))
import qualified Data.Yaml                       as Yaml
import           GHC.IO.Encoding
  (setLocaleEncoding, setForeignEncoding, utf8)

import           Options.Applicative             hiding (info)
import qualified Options.Applicative             as O

import           System.Directory
import           System.Environment              (lookupEnv, setEnv)
import           System.Environment.Executable   (getExecutablePath)
import           System.Exit
  (exitSuccess, exitFailure, ExitCode(..))
import qualified System.FilePath                 as FP
import           System.FilePath --  hiding ((<.>), (</>))

import           System.IO
  (hPutStrLn, hSetBuffering, stderr, stdout, BufferMode(..), hClose)
import           System.PosixCompat.Files        (setFileMode)
import           System.Process                  (readCreateProcess, createProcess, waitForProcess, {-CreateProcess(..),-} proc)

-- import           Shelly                          ((<.>), fromText)
-- import qualified Shelly                          as Sh

import           Compiler.GhcjsProgram           (printVersion)
import qualified Compiler.Info                   as Info
import qualified Compiler.Utils                  as Utils
import           Compiler.Settings               (NodeSettings(..))

-- import qualified Paths_ghcjs                     as Paths

import           System.IO.Error                 (isDoesNotExistError)
import           Compiler.Platform               (isWindows)

-- fixme force overwrite?

default (Text)

newtype Verbosity = Verbosity Int deriving (Eq, Ord, Data, Typeable)

trace, info, warn, err :: Verbosity
trace = Verbosity 3
info  = Verbosity 2
warn  = Verbosity 1
err   = Verbosity 0

data BootSettings = BootSettings
  { _bsShowVersion  :: Bool       -- ^show the version and exit
  , _bsDebug        :: Bool       {- ^build debug version of the libraries
                                      (GHCJS records the STG in the object
                                      files for easier inspection) -}
  , _bsProf         :: Bool       -- ^build profiling version of the libraries
  , _bsHaddock      :: Bool       -- ^build documentation
  , _bsVerbosity    :: Verbosity  -- ^verbosity level 0..3, 2 is default
  , _bsWithCabal    :: Maybe Text {- ^location of cabal (cabal-install)
                                      executable, must have GHCJS support -}
  -- , _bsBindir       :: Maybe Text -- ^ bin directory to install GHCJS programs
  -- , _bsLibexecDir :: Maybe Text -- ^ location of GHCJS executables
  -- , _bsGhcjsLibdir  :: Maybe Text -- ^ location to install GHCJS boot libraries
  , _bsWithEmsdk    :: Maybe Text
  , _bsWithGhc      :: Maybe Text {- ^location of GHC compiler (must have a
                                      GHCJS-compatible Cabal library
                                      installed. ghcjs-boot copies some files
                                      from this compiler) -}
  , _bsWithNode     :: Maybe Text -- ^location of the node.js program
  , _bsWithNodePath :: Maybe Text -- ^ NODE_PATH to use when running node.js Template Haskell or REPL
                                  --      (if unspecified, GHCJS uses bundled packages)
  , _bsNodeExtraArgs :: Maybe Text -- ^ extra node arguments
  , _bsSourceDir    :: Maybe Text -- ^source directory (can be a tar file)
  } deriving (Ord, Eq, Data, Typeable)


{- | Stage configuration file: packages to install in each stage

     see boot.yaml for more information
 -}
data BootStages = BootStages
  { _bstStage1a   :: Stage
  , _bstStage1b   :: Stage
  , _bstCabal     :: Package   {- ^installed between 1b and 2,
                                   only when doing a full boot -}
  , _bstGhcjsPrim :: Package   -- ^installed between 1a and 1b
  } deriving (Data, Typeable)

type Stage   = [Package]

type Package = Text {- ^just the package name/location, unversioned

                        can be a directory name
                        (starting with ./ relative to the ghcjs-boot root),
                        a url or a plain package name
                     -}

data BootLocations = BootLocations
  { _blSourceDir   :: FilePath
  , _blBuildDir    :: FilePath
  , _blGhcjsTopDir :: FilePath
  , _blGlobalDB    :: FilePath -- ^global package database
  -- , _blLibexecDir  :: FilePath
  , _blEmsdk       :: FilePath
  } deriving (Data, Typeable, Show)

data Program = Program
  { _pgmName    :: Text           -- ^program name for messages
  , _pgmSearch  :: Text           {- ^name searched for when configuring the
                                      program (from command line or config file)
                                   -}
  , _pgmVersion :: Maybe Text     -- ^version if known
  , _pgmLoc     :: Maybe FilePath -- ^absolute path to the program
  , _pgmArgs    :: [Text]         -- ^extra arguments to pass to the program
  } deriving (Data, Typeable, Show)

-- | configured programs, fail early if any of the required programs is missing
data BootPrograms = BootPrograms { _bpGhc        :: Program
                                 , _bpCabal      :: Program
                                 , _bpNode       :: Program
                                 } deriving (Data, Typeable, Show)

data BootEnv = BootEnv { _beSettings  :: BootSettings
                       , _beLocations :: BootLocations
                       , _bePrograms  :: BootPrograms
                       , _beStages    :: BootStages
                       }

data BootConfigFile = BootConfigFile BootStages BootPrograms
  deriving (Data, Typeable)

makeLenses ''Program
makeLenses ''BootSettings
makeLenses ''BootLocations
makeLenses ''BootPrograms
makeLenses ''BootStages
makeLenses ''BootEnv

main :: IO ()
main = do
    settings <- execParser optParser'
    when (settings ^. bsShowVersion) (printVersion >> exitSuccess)
    hSetBuffering stdout LineBuffering
    setLocaleEncoding utf8
    setForeignEncoding utf8
    env <- initBootEnv settings
    printBootEnvSummary False env
    r <- runReaderT ((actions >> pure Nothing)
                        `catchAny` (pure . Just)) env
    maybe exitSuccess Ex.throwIO r
  where
    actions :: B ()
    actions = do
      e <- ask
      liftIO $ setEnv "GHC_CHARENC" "UTF-8"
      cleanCache
      prepareLibDir
      let base = libDir (e ^. beLocations)
      liftIO $ setEnv "CFLAGS" ("-I" <> (base </> "include"))
      installStage1
      installCabal
      when (e ^. beSettings . bsHaddock) buildDocIndex
      liftIO . printBootEnvSummary True =<< ask

instance Yaml.FromJSON BootPrograms where
  parseJSON (Yaml.Object v) = BootPrograms
    <$> v ..: "ghc"
    <*> v ..: "cabal"
    <*> v ..: "node"
    where
      o ..: p = ((\t -> Program p t Nothing Nothing []) <$> o .: p) <|>
                (withArgs p =<< o .: p)
      withArgs :: Text -> Yaml.Value -> Yaml.Parser Program
      withArgs p (Yaml.Object o) | [(k,v)] <- HM.toList o =
        Program p k Nothing Nothing <$> Yaml.parseJSON v
      withArgs _ _ =
        mempty
  parseJSON _ = mempty

instance Yaml.FromJSON BootStages where
  parseJSON (Yaml.Object v) = BootStages
    <$> v ..: "stage1a"
    <*> v ..: "stage1b"
    <*> v  .: "cabal"
    <*> v  .: "ghcjs-prim"
    where
      o ..: p = pkgs =<< o .: p
      pkgs (Yaml.String t) =
        pure [t]
      pkgs (Yaml.Array v) =
        concat <$> mapM pkgs (V.toList v)
      pkgs __ =
        mempty
  parseJSON _ = mempty

instance Yaml.FromJSON BootConfigFile where
  parseJSON (Yaml.Object v) = BootConfigFile
    <$> v .: "packages" <*> v .: "programs"
  parseJSON _ = mempty

optParser' :: ParserInfo BootSettings
optParser' =
  O.info (helper <*> optParser)
         (fullDesc <>
          header "GHCJS booter, build base libraries for the compiler" <>
          progDesc description)

description :: String
description = unlines
  [ "ghcjs-boot builds an initial set of libraries for GHCJS."
  ]

optParser :: Parser BootSettings
optParser =
  BootSettings
    <$> switch
        (long "version" <>
        help "show the ghcjs-boot version")
    <*> switch
          (long "debug" <>
           short 'd' <>
           help "build debug libraries with extra checks")
    <*> (fmap not . switch)
          (long "no-prof" <>
           help "don't generate profiling version of the libraries")
    <*> (fmap not . switch)
          (long "no-haddock" <>
           help "don't generate documentation")
    <*> (fmap Verbosity . option auto)
          (long "verbosity" <>
           short 'v' <>
           value 2 <>
           help "verbose output")
    <*> (optional . fmap T.pack . strOption)
          (long "with-cabal" <> metavar "PROGRAM" <>
           help "cabal program to use")
    <*> (optional . fmap T.pack . strOption)
          (long "with-emsdk" <>
           metavar "DIR" <>
           help "location of Emscripten SDK")
    <*> (optional . fmap T.pack . strOption)
          (long "with-ghc" <>
           metavar "PROGRAM" <>
           help "ghc program to use")
    <*> (optional . fmap T.pack . strOption)
          (long "with-node" <>
           metavar "PROGRAM" <>
           help "node.js program to use")
    <*> (optional . fmap T.pack . strOption)
          (long "with-node-path" <> metavar "PATH" <>
           help "value of NODE_PATH environment variable when running Template Haskell or GHCJSi")
    <*> (optional . fmap T.pack . strOption)
          (long "extra-node-args" <> metavar "ARGS" <>
           help "extra arguments to pass to node.js")
    <*> (optional . fmap T.pack . strOption)
          (long "source-dir" <>
           short 's' <>
           metavar "DIR" <>
           help "location of GHCJS library sources")

initPackageDB :: B ()
initPackageDB = do
  msg info "creating package databases"
  initDB "--global" <^> beLocations . blGlobalDB
  where
    initDB dbName db = do
      rm_rf db
      ghcjs_pkg_ ["init", T.pack db] `catchAny_` return ()
      ghcjs_pkg_ ["recache", dbName]

cleanCache :: B ()
cleanCache =
  liftIO Info.getUserCacheDir >>= \case
    Just p -> rm_rf p `catchAny_` return ()
    Nothing -> return ()

prepareLibDir :: B ()
prepareLibDir = do
  msg info "preparing GHCJS library directory"
  locs <- view beLocations
  pgms <- view bePrograms
  liftIO $ print (locs, pgms)
  ver <- liftIO $ ghcjsVersion pgms
  let globalDB = locs ^. blGlobalDB
      ghcjsLib = libDir locs
      ghcjsTop = locs ^. blGhcjsTopDir
      rtsConfFile   = "rts.conf"
      wrapperSrcDir = (locs ^. blSourceDir) </> "input" </> "wrappers"
      wenv = WrapperEnv { weTopDir     = T.pack (libDir locs)
                        , weBinDir     = T.pack ((locs ^. blGhcjsTopDir) </> "bin")
                        , weLibexecDir = T.pack (libDir locs </> "bin")
                        , weVersion    = ver
                        , weGhcVersion = ver
                        , weEmsdk      = T.pack (locs ^. blEmsdk)
                        }
  rtsConf <- replacePlaceholders wenv <$>
             liftIO (T.readFile ((locs ^. blSourceDir) </> "input" </> "rts" <.> "conf"))
  mkdir_p (ghcjsLib </> "bin")

  msg info "copying GHCJS executables"

  -- copy the executables from the package to the libraries directory
  -- (the executables in the package have been prefixed with `private-ghcjs-`
  -- as a workaround for cabal-install incorrectly generating symlinks for
  -- private executables)
  let cpExe name = do
        let srcName = ghcjsTop </> "bin" </> exe (T.unpack $ "private-ghcjs-" <> name)
            tgtName = ghcjsLib </> "bin" </> exe (T.unpack name)
        cp srcName tgtName
        liftIO . Cabal.setFileExecutable $ tgtName

  mapM_ cpExe [ "unlit", "run" ]

  when isWindows (mapM_ cpExe ["touchy", "wrapper"])

  msg info "creating emscripten wrapper"

  liftIO $ copyWrapper "emcc"
                       Nothing
                       wenv
                       (ghcjsLib </> "bin")
                       wrapperSrcDir
                       (ghcjsLib </> "bin")

  msg info "adding RTS package"
  initPackageDB
  liftIO $ T.writeFile (globalDB </> rtsConfFile) rtsConf
  ghcjs_pkg_ ["recache", "--global", "--no-user-package-db"]
  cp_r ((locs ^. blSourceDir) </> "shims") (ghcjsLib </> "shims")
  cp_r ((locs ^. blSourceDir) </> "data")  ghcjsLib
  liftIO . T.writeFile (ghcjsLib </> "settings") =<< generateSettings
  -- workaround for hardcoded check of mingw dir in ghc when building on Windows
  when isWindows (mkdir_p $ ghcjsTop </> "mingw")
  prepareNodeJs
  unless isWindows $ do
    let runSh = ghcjsLib </> "run" <.> "sh"
    liftIO (T.writeFile runSh "#!/bin/sh\nCOMMAND=$1\nshift\n\"$COMMAND\" \"$@\"\n")
    liftIO (Cabal.setFileExecutable =<< makeAbsolute runSh)
  -- make an empty object file for
  subLib $ do
    liftIO (T.writeFile "empty.c" "")
    ghc_ ["-c", "empty.c"]
  msg info "RTS prepared"

generateSettings :: B Text
generateSettings = do
  emsdk <- view (beLocations . blEmsdk)
  -- do we also need emar, emranlib?
  let opts :: [(String, String)]
      opts = [("GCC extra via C opts", " -fwrapv -fno-builtin"),
              ("C compiler command", emsdk </> "upstream" </> "bin" </> "clang" {-"asmjs-none-gcc"-} {-T.unpack emccProgram-}),
              ("C compiler flags", ""),
              ("C++ compiler flags",""),
              ("C compiler link flags", " "),
              ("C compiler supports -no-pie", "NO"),
              ("Haskell CPP command", emsdk </> "upstream" </> "bin" </> "clang"),
              ("Haskell CPP flags","-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs"),
              ("ld command", "ld"),
              ("ld flags", ""),
              ("ld supports compact unwind", "YES"),
              ("ld supports build-id", "NO"),
              ("ld supports filelist", "YES"),
              ("ld is GNU ld", "NO"),
              ("Merge objects command", "ld.gold"),
              ("Merge objects flags", "-r"),
              ("ar command", emsdk </> "upstream" </> "emscripten" </> "emar"),
              ("ar flags", "qcls"),
              ("ar supports at file", "NO"),
              ("ranlib command", emsdk </> "upstream" </> "emscripten" </> "emranlib"),
              ("otool command", "otool"),
              ("install_name_tool command", "install_name_tool"),
              ("touch command", if isWindows then "$topdir/bin/touchy.exe" else "touch"),
              ("dllwrap command", "/bin/false"),
              ("windres command", "/bin/false"),
              ("libtool command", "libtool"),
              ("unlit command", "$topdir/bin/unlit"),
              ("cross compiling", "YES"),
              ("target os", "OSUnknown"),
              ("target arch", "ArchJavaScript"),
              ("target platform string", T.unpack ghcjsTriple),
              ("Target platform", T.unpack ghcjsTriple),
              ("target word size", "4"),
              ("target has GNU nonexec stack", "NO"),
              ("target has .ident directive", "YES"),
              ("target has subsections via symbols", "YES"),
              ("target has RTS linker", "YES"),
              ("integer library", "integer-gmp"),
              ("Unregisterised", "YES"),
              ("LLVM target", T.unpack ghcjsTriple),
              ("LLVM llc command", "llc"),
              ("LLVM opt command", "opt"),
              ("LLVM clang command", "clang"),
              ("Tables next to code","YES"),
              ("Use interpreter","YES"),
              ("Use native code generator","YES"),
              ("Support SMP","NO"),
              ("RTS ways","l debug debug_p"),
              ("Leading underscore","NO"),
              ("Use LibFFI","NO"),
              ("Use Threads","YES"),
              ("Use Debugging","NO"),
              ("RTS expects libdw","NO"),
              ("Support parallel --make","YES"),
              ("Support reexported-modules","YES"),
              ("Support thinning and renaming package flags","YES"),
              ("Support Backpack","YES"),
              ("Requires unified installed package IDs","YES"),
              ("Uses package keys","YES"),
              ("Uses unit IDs","YES")
              ]
  pure $ T.pack ("[" ++ intercalate ",\n" (map show opts) ++ "\n]")


prepareNodeJs :: B ()
prepareNodeJs = do
  ghcjsLib <- libDir <$> view beLocations
  buildDir <- view (beLocations . blBuildDir)
  nodeProgram <- view (bePrograms . bpNode . pgmLoc . to (maybe "-" T.pack))
  mbNodePath  <- view (beSettings . bsWithNodePath)
  extraArgs   <- view (beSettings . bsNodeExtraArgs)
  -- If no setting for NODE_PATH is specified, we use the libraries bundled
  -- with the ghcjs-boot submodule. We must run "npm rebuild" to build
  -- any sytem-specific components.
  when (isNothing mbNodePath) $ do
    subLib (mkdir_p "ghcjs-node")
    liftIO $ unpackTar False
                       True
                       ghcjsLib
                       (buildDir </> "ghcjs-node.tar")
    subLib' "ghcjs-node" $ npm_ ["rebuild"]
  -- write nodeSettings.json file
  let nodeSettings = NodeSettings
       { nodeProgram         = T.unpack nodeProgram
       , nodePath            = mbNodePath
       , nodeExtraArgs       = maybeToList extraArgs
       , nodeKeepAliveMaxMem = 536870912
       }
  liftIO $ BL.writeFile (T.unpack . T.pack $ ghcjsLib </> "nodeSettings.json")
                        (Aeson.encode $ Aeson.toJSON nodeSettings)

exe :: FilePath -> FilePath
exe = bool isWindows (<.>"exe") id

buildDocIndex :: B ()
buildDocIndex = subTop' "doc" $ do
  haddockFiles <- findWhen (return . isExtensionOf "haddock") "."
  haddock_ $ ["--gen-contents"
             ,"--gen-index"
             , "-o"
             , "html"
             , "--title=GHCJS Libraries"
             ] ++
             map (\p -> "--read-interface=../" <>
                        T.pack (takeDirectory p) <>
                        "," <>
                        T.pack p)
                 haddockFiles

installCabal :: B ()
installCabal = subBuild $ do
  msg info "installing Cabal library"
  preparePackage "Cabal"
  buildCabalPackage "Cabal"

installGhcjsPrim :: B ()
installGhcjsPrim = do
  msg info "installing ghcjs-prim"
  preparePackage "ghcjs-prim"
  buildCabalPackage "ghcjs-prim"

installGhcjsTh :: B ()
installGhcjsTh = do
  msg info "installing ghcjs-th"
  preparePackage "ghcjs-th"
  buildCabalPackage "ghcjs-th"

installStage1 :: B ()
installStage1 = subBuild $ do
  buildCabalPackage "ghc-prim"
  mapM_ installPackage =<< stagePackages bstStage1a
  installGhcjsPrim
  mapM_ installPackage =<< stagePackages bstStage1b
  installGhcjsTh
  resolveWiredInPackages
    where
      installPackage pkg = do
        msg info ("installing package " <> pkg)
        preparePackage pkg
        buildCabalPackage pkg

resolveWiredInPackages :: B ()
resolveWiredInPackages = subLib $ do
  wips <- readBinary ("wiredinpkgs" <.> "yaml")
  case Yaml.decodeEither' wips of
   Left err   -> failWith $
     "error parsing wired-in packages file wiredinpkgs.yaml\n" <> T.pack (show err)
   Right pkgs -> do
     pkgs' <- forM pkgs $ \p ->
       (p,) . T.strip <$> ghcjs_pkg [ "--simple-output"
                                    , "field"
                                    , p
                                    , "key"
                                    ]
     liftIO (T.writeFile ("wiredinkeys" <.> "yaml") (
       T.unlines ("# resolved wired-in packages" :
                  map (\(p,k) -> p <> ": " <> k) pkgs')))

preparePackage :: Package -> B ()
preparePackage pkg
  | "./" `T.isPrefixOf` pkg || "../" `T.isPrefixOf` pkg = sub $ do
    msg trace ("preparing package " <> pkg)
    cd (T.unpack pkg)
    rm_rf "dist"
  | otherwise = return ()

-- | subshell in path relative to build dir
subBuild :: B a -> B a
subBuild a = sub (view (beLocations . blBuildDir) >>= cd >> a)

-- | subshell in path relative to top installation dir
subTop' :: FilePath -> B a -> B a
subTop' p a = subTop (cd p >> a)

subTop :: B a -> B a
subTop a = sub (view (beLocations . blGhcjsTopDir) >>= cd >> a)

subLib' :: FilePath -> B a -> B a
subLib' p a = subLib (cd p >> a)

subLib :: B a -> B a
subLib a = sub ((libDir <$> view beLocations) >>= cd >> a)

{- |unpack a tar file (does not support compression)
    only supports files, does not try to emulate symlinks -}
unpackTar :: Bool             -- ^strip the first directory component?
          -> Bool             -- ^preserve symbolic links?
          -> Prelude.FilePath -- ^destination to unpack to
          -> Prelude.FilePath -- ^the tar file
          -> IO ()
unpackTar stripFirst preserveSymlinks dest tarFile = do
  createDirectoryIfMissing True dest
  entries <- Tar.read . BL.fromStrict <$> B.readFile tarFile
  void $ Tar.foldEntries (\e -> (>>=checkExtract e))
                         (return Nothing)
                         (\e -> failWith $ "error unpacking tar: " <> showT e)
                         entries
    where
      failSec e msg = failWith $ "tar security check, " <>
                                 msg <>
                                 ": " <>
                                 T.pack (Tar.entryPath e)
      checkExtract e Nothing
        | (p:_) <- FP.splitDirectories (Tar.entryPath e)
            = checkExtract e (Just p)
        | otherwise = failSec e $
            "no path"
      checkExtract e je@(Just expected)
        | FP.isAbsolute ep = failSec e $
            "absolute path"
        | elem ".." epd              = failSec e $
            "'..' in path"
        | listToMaybe epd /= je &&
          isSupportedEntry (Tar.entryContent e) = failSec e $
            "tar bomb, expected path component: " <> T.pack expected
        | otherwise                     = do
            (extractEntry e $ dest FP.</>
                   (FP.joinPath
                                (drop (if stripFirst then 1 else 0) epd)))
            return je
        where ep  = Tar.entryPath e
              epd = FP.splitDirectories ep
      isSupportedEntry Tar.NormalFile{} = True
      isSupportedEntry Tar.Directory{}  = True
      isSupportedEntry _                = False
      extractEntry :: Tar.Entry -> Prelude.FilePath -> IO ()
      extractEntry e tgt
        | Tar.NormalFile bs _size <- Tar.entryContent e = do
            createDirectoryIfMissing True (FP.dropFileName tgt)
            BL.writeFile tgt bs
            setPermissions (Tar.entryPermissions e) tgt
        | Tar.Directory <- Tar.entryContent e = do
            createDirectoryIfMissing True tgt
            setPermissions (Tar.entryPermissions e) tgt
        | Tar.SymbolicLink _linkTgt <- Tar.entryContent e
        , preserveSymlinks =
            createDirectoryIfMissing True (FP.dropFileName tgt)
        | otherwise = hPutStrLn stderr $
            "ignoring unexpected entry type in tar. " <>
            "only normal files and directories (no links) " <>
            "are supported:\n    " <> tgt
      setPermissions mode tgt = do
        absTgt <- makeAbsolute tgt
        setFileMode absTgt mode

run_inplace :: Text -> [Text] -> B Text
run_inplace pgm args = do
  ghcjsTop <- view (beLocations . blGhcjsTopDir)
  run'' (ghcjsTop </> "bin" </> T.unpack pgm) "" args

run_inplace_ :: Text -> [Text] -> B ()
run_inplace_ pgm args = do
  ghcjsTop <- view (beLocations . blGhcjsTopDir)
  run''_ (ghcjsTop </> "bin" </> T.unpack pgm) args

ghc_ :: [Text] -> B ()
ghc_         = runE_ bpGhc

ghcjs_pkg :: [Text] -> B Text
ghcjs_pkg = run_inplace "ghcjs-pkg"

ghcjs_pkg_ :: [Text] -> B ()
ghcjs_pkg_   = run_inplace_ "ghcjs-pkg"

haddock_ :: [Text] -> B ()
haddock_     = run_inplace_ "haddock"

npm_ :: [Text] -> B ()
npm_ args = do
  nodePgm <- view (bePrograms . bpNode)
  case nodePgm ^. pgmLoc of
    Nothing -> failWith "nodejs program not configured when trying to run npm"
    Just loc ->
      if isWindows
      then do
        sysRoot <- fromMaybe "C:\\WINDOWS" <$> liftIO (Utils.getEnvMay "SYSTEMROOT")
        let cmdLoc = sysRoot </> "system32" </> "cmd" <.> "exe"
            npmLoc = FP.takeDirectory loc </> "npm" <.> "cmd"
        run''_ cmdLoc ("/C" : T.pack npmLoc : args)
      else do
        let npmLoc = FP.takeDirectory loc </> "npm"
        run''_ npmLoc args

runE_ :: ((Program -> Const Program Program)
      -> BootPrograms -> Const Program BootPrograms)
      -> [Text] -> B ()
runE_ g a = view (bePrograms . g) >>= \p -> run_ p a

customSetupPackages :: [Text]
customSetupPackages = [ "ghc-prim" ]

cabalConfigureFlags :: B [Text]
cabalConfigureFlags = do
  debug    <- view (beSettings . bsDebug)
  v        <- view (beSettings . bsVerbosity)
  instDir  <- libDir <$> view beLocations
  prof     <- view (beSettings . bsProf)
  locs     <- view beLocations
  let binDir        = (locs ^. blGhcjsTopDir) </> "bin"
      privateBinDir = instDir </> "bin"
  return $ [ "--global"
           , "--ghcjs"
           , "--builddir",      "dist"
           , "--with-compiler", (T.pack $ binDir </> "ghcjs")
           , "--with-hc-pkg",   (T.pack $ binDir </> "ghcjs-pkg")
           , "--with-haddock",  (T.pack $ binDir </> "haddock")
           , "--with-gcc",      (T.pack $ privateBinDir </> "emcc")
           , "--prefix",        T.pack (locs ^. blGhcjsTopDir)
           , "--configure-option", "--host=js-unknown-ghcjs"
           , "--ghcjs-options=-fwrite-ide-info"
           , "--enable-debug-info"
           , "--disable-library-stripping"
           , "--disable-executable-stripping"
           , "-fghci"
           , bool prof
                  "--enable-profiling"
                  "--disable-profiling"
           ] ++
           -- don't slow down Windows builds too much,
           -- on other platforms we get this more
           -- or less for free, thanks to dynamic-too
           bool isWindows [] ["--enable-shared"] ++
           catMaybes [ bj debug "--ghcjs-options=-debug"
                     , bj (v > info) "-v2"
                     ]


buildCabalPackage :: Text -> B ()
buildCabalPackage pkg = subBuild $ do
  cd ("pkg" </> T.unpack pkg) -- hopefully correct
  -- build custom setup if necessary
  msg info ("configuring package: " <> pkg)
  configureFlags <- cabalConfigureFlags
  haddock  <- view (beSettings . bsHaddock)

  -- configure / build
  liftIO $ setEnv "GHCJS_BOOTING" "1"
  case pkg `elem` customSetupPackages of
                True -> do
                  {-
                     XXX there is only one custom setup package

                         we should probably just build the ghc-prim
                         Setup.hs as part of the ghcjs package, so
                         we can avoid having to know about GHC at all
                         (and have proper dependencies)
                    -}
                  ghc <- requirePgmLoc =<< view (bePrograms . bpGhc)
                  run''_ ghc ["Setup.hs"]
                  let setup args = run''_ "./Setup" args
                  setup ("configure" : configureFlags)
                  setup ["build"]
                  when haddock (setup ["haddock"])
                  setup ["copy"]
                  setup ["register"]
                _ -> do
                  cmd <- requirePgmLoc =<< view (bePrograms . bpCabal)
                  let setup args = run''_ cmd args
                  setup ("v1-configure" : configureFlags)
                  setup ["v1-build"]
                  when haddock (setup ["v1-haddock"])
                  setup ["v1-copy"]
                  setup ["v1-register"]

stagePackages :: Getter BootStages Stage -> B [Package]
stagePackages l = view (beStages . l)

failWith :: MonadIO m => Text -> m a
failWith err = liftIO (T.putStrLn ("fatal: " <> err) >> exitFailure)

{- |initialize our boot environment by reading the configuration files,
    finding all programs -}
initBootEnv :: BootSettings -> IO BootEnv
initBootEnv bs = do
  BootConfigFile stgs pgms1 <- readBootConfigFile bs
  pgms2 <- configureBootPrograms bs pgms1
  locs  <- configureBootLocations bs pgms2
  -- installWrappers ((locs ^. blGhcjsTopDir) </> "bin") locs pgms2
  return (BootEnv bs locs pgms2 stgs)

-- the platform triple that GHCJS reports
-- this is in practice mostly used for the toolchain
ghcjsTriple :: Text
ghcjsTriple = "js-unknown-ghcjs"

-- this assumes that the ghcjs-boot version is correct. perhaps we should query the ghcjs executable to verify?
ghcjsVersion :: BootPrograms -> IO Text
ghcjsVersion _ = pure (T.pack Info.getCompilerVersion)

libSubDir :: FilePath
libSubDir = "lib"

libDir :: BootLocations -> FilePath
libDir locs = (locs ^. blGhcjsTopDir) </> libSubDir

data WrapperEnv = WrapperEnv { weTopDir     :: Text
                             , weBinDir     :: Text
                             , weLibexecDir :: Text
                             , weVersion    :: Text
                             , weGhcVersion :: Text
                             , weEmsdk      :: Text
                             } deriving (Show)
--

copyWrapper :: Text
            -> Maybe Text
            -> WrapperEnv
            -> FilePath
            -> FilePath
            -> FilePath
            -> IO ()
copyWrapper = if isWindows then copyWrapperW else copyWrapperU

{- |
     on Windows we can't run shell scripts, so we don't install wrappers
     just copy program.exe to program-{version}-{ghcversion}.exe

     the programs read a program-{version}-{ghcversion}.exe.options file from
     the same directory, which contains the command line arguments to prepend

     installation does not overwrite existing .options files
 -}

copyWrapperW :: Text
             -> Maybe Text
             -> WrapperEnv
             -> FilePath
             -> FilePath
             -> FilePath
             -> IO ()
copyWrapperW programName mbVer env libexecDir wrapperSrcDir binDir = do
    createDirectoryIfMissing False binDir
    Cabal.installExecutableFile verbosity srcExe tgtExe
    whenVer (Cabal.installExecutableFile verbosity srcExe tgtExeVersioned)
    options <- replacePlaceholders env <$> T.readFile (wrapperSrcDir </> T.unpack programName <.> "exe" <.> "options")
    createDirectoryIfMissing False binDir
    Cabal.withTempFile binDir "ghcjs-options-XXXXXX.tmp" $ \tmp h -> do
        T.hPutStr h options
        hClose h
        Cabal.installOrdinaryFile verbosity tmp tgtOptions
        whenVer (Cabal.installOrdinaryFile verbosity tmp tgtOptionsVersioned)
  where
    verbosity           = Cabal.verbose
    whenVer x           = when (isJust mbVer) x
    srcExe              = libexecDir </> "wrapper" <.> "exe"

    tgtPrefix           = binDir </> T.unpack programName
    tgtPrefixVersioned  = binDir </> T.unpack (programName <> "-" <> ver)

    tgtExe              = tgtPrefix <.> "exe"
    tgtOptions          = tgtExe <.> "options"
    tgtExeVersioned     = tgtPrefixVersioned <.> "exe"
    tgtOptionsVersioned = tgtExeVersioned <.> "options"
    ver = fromMaybe "0.0.0" mbVer

{- |
     on non-Windows we copy shell scripts that pass the -B flag to ghcjs,
     ghcjs-pkg etc

     installation updates the symlink, but does not overwrite the wrapper
     scripts if they already exist

     if no wrapper is required, we simply symlink to the executable in the
     libexec directory
 -}

copyWrapperU :: Text
             -> Maybe Text
             -> WrapperEnv
             -> FilePath
             -> FilePath
             -> FilePath
             -> IO ()
copyWrapperU programName mbVer env libexecDir wrapperSrcDir binDir = do
  putStrLn ("installing wrapper for: " ++ show (programName, mbVer, libexecDir, wrapperSrcDir, binDir))
  createDirectoryIfMissing False binDir
  wrapperScript <- replacePlaceholders env <$> T.readFile (wrapperSrcDir </> T.unpack programName <.> "sh")
  Cabal.withTempFile binDir "ghcjs-wrapper-XXXXXX.tmp" $
      (\tmp h -> do T.hPutStr h wrapperScript
                    hClose h
                    Cabal.installExecutableFile Cabal.normal tmp (binDir </> tgt))
  when (isJust mbVer) (linkFileU Cabal.normal binDir tgt tgtPlain)
  where
    tgtPlain = T.unpack programName
    tgt      = maybe tgtPlain
                     (\ver -> T.unpack (programName <> "-" <> ver))
                     mbVer

{- |
     create a symlink, overwriting the target. unix only.

     it looks like the Cabal library does not have this functionality,
     and since we shouldn't use system-specific libraries here,
     we use a shell command instead.

     the symlink is relative if both files are in the same directory
  -}
linkFileU :: Cabal.Verbosity -> FilePath -> FilePath -> FilePath -> IO ()
linkFileU _v workingDir src dest = do
  -- putStrLn ("link file: " ++ show (workingDir, src, dest))
  let ignoreDoesNotExist :: IOError -> IO ()
      ignoreDoesNotExist e | isDoesNotExistError e = return ()
                           | otherwise             = Ex.throw e
  removeFile (workingDir </> dest) `Ex.catch` ignoreDoesNotExist
  wd <- getCurrentDirectory
  setCurrentDirectory workingDir
  createFileLink src dest
  setCurrentDirectory wd

-- | replace placeholders in a wrapper script or options file
replacePlaceholders :: WrapperEnv -> Text -> Text
replacePlaceholders env xs =
  foldl (\ys (p,r) -> T.replace p (r env) ys) xs
    [ ("{topdir}",     weTopDir)
    , ("{bindir}",     weBinDir)
    , ("{libexecdir}", weLibexecDir)
    , ("{version}",    weVersion)
    , ("{ghcversion}", weGhcVersion)
    , ("{emsdk}",      weEmsdk)
    ]

{- | try to find the emsdk directory
       1. check --with-emsdk option
       2. check EMSDK environment variable
       3. find emcc executable in PATH
 -}
configureEmsdkDir :: BootSettings
                  -> IO FilePath
configureEmsdkDir bs
  | Just dir <- bs ^. bsWithEmsdk = pure (T.unpack dir)
  | otherwise = do
    e <- lookupEnv "EMSDK"
    case e of
      Just edir -> pure edir
      _         -> do
        mbEmccExe <- findExecutable "emcc"
        case mbEmccExe of
          Just emccExe ->
            {- if we found the `emcc' executable, we just assume
               that it's two directories deeper than the emsdk root
               path, e.g. fastcomp/bin, fastcomp/emscripten, upstream/bin

               perhaps we should change this to check for the emsdk python
               script itself.
             -}
            let emccDirParts = FP.splitPath (FP.takeDirectory emccExe)
            in  pure (concat . reverse . drop 2 . reverse $ emccDirParts)
          _ -> notFound
  where
    notFound = failWith "emscripten emsdk not found (use --with-emsdk)"

-- | configure the locations
configureBootLocations :: BootSettings
                       -> BootPrograms
                       -> IO BootLocations
configureBootLocations bs _pgms = do
  -- take the location of the ghcjs-boot program and configure the
  -- installation directory relative to that
  bootPath <- getExecutablePath
  ghcjsTopDir <- canonicalizePath (FP.dropFileName bootPath </> "..")
  let ghcjsLibDir = ghcjsTopDir </> libSubDir
      globalDB = ghcjsLibDir </> "package.conf.d"

  -- the source directory is specified by the user
  sourceDir <- bootSourceDir bs
  buildDir <- prepareBuildDir sourceDir ghcjsLibDir
  emsdkDir <- configureEmsdkDir bs
  pure $ BootLocations sourceDir
                        buildDir
                        ghcjsTopDir
                        globalDB
                        emsdkDir

prepareBuildDir :: Prelude.FilePath
                -> Prelude.FilePath
                -> IO Prelude.FilePath
prepareBuildDir srcDir ghcjsLibDir = do
  e <- doesFileExist srcDir
  if e then do let bootDir = ghcjsLibDir FP.</> "boot"
               bootExists <- doesDirectoryExist  bootDir
               when bootExists (removeDirectoryRecursive bootDir)
               unpackTar False False ghcjsLibDir srcDir
               pure bootDir
       else do
         d <- doesDirectoryExist srcDir
         if d then do
                e <- doesFileExist (srcDir FP.</> "boot" FP.<.> "yaml")
                if e then pure srcDir else err
              else err
   where
     err = failWith "source location must contain boot.yaml or be a tar file"

-- |build the program configuration and do some sanity checks
configureBootPrograms :: BootSettings    -- ^command line settings
                      -> BootPrograms    -- ^default programs from config file
                      -> IO BootPrograms -- ^configured programs
configureBootPrograms bs pgms0 = do
  -- first replace all defaults with the overrides from the command line
  let
      r l   = maybe id (pgmSearch .~) (bs ^. l)
      tp    = template :: Traversal' BootPrograms Program
      pgms2 = pgms0 & bpCabal    %~ r bsWithCabal
                    & bpNode     %~ r bsWithNode
  -- resolve all programs
  pgms3 <- mapMOf tp (resolveProgram bs)
             =<< mapMOf tp (resolveProgram bs) pgms2
  traverseOf_ tp (reportProgramLocation bs) pgms3
  return pgms3

resolveProgram :: BootSettings
               -> Program
               -> IO Program
resolveProgram _bs pgm = do
  let search' = pgm ^. pgmSearch . to T.unpack
  absSearch <- (</> search') <$> getCurrentDirectory
  let searchPaths = catMaybes [ Just search'
                              , bj (isRelative search' &&
                                    length (splitDirectories search') > 1)
                                   absSearch
                              ]
  fmap catMaybes (mapM findExecutable searchPaths) >>= \case
      (p':_) -> (\cp -> pgm & pgmLoc ?~ cp) <$> return p'
      _      -> return (pgm & pgmLoc .~ Nothing)

-- | report location of a configured program
reportProgramLocation :: BootSettings -> Program -> IO ()
reportProgramLocation bs p
  | Just l <- p ^. pgmLoc = msg' bs info $ "program " <>
                                           p ^. pgmName <>
                                           " found at " <>
                                           T.pack l
  | otherwise             = msg' bs info $ "program " <>
                                           p ^. pgmName <>
                                           " NOT found, searched for " <>
                                           p ^. pgmSearch

-- | read the boot configuration yaml file
readBootConfigFile :: BootSettings -> IO BootConfigFile
readBootConfigFile bs = do
  bf <- bootConfigFile bs
  case Yaml.decodeEither' bf of
    Left err  -> failWith $
      "error parsing boot.yaml configuration file\n" <>
      T.pack (show err)
    Right bss -> return bss

printBootEnvSummary :: Bool -> BootEnv -> IO ()
printBootEnvSummary after be = do
  section "Boot libraries installation for GHCJS" $ do
    bootLoc  <- getExecutablePath
    bootMod  <- getModificationTime bootLoc
    bootSrc  <- bootSourceDir (be ^. beSettings)
    curDir   <- getCurrentDirectory
    p $ bool after
          ["ghcjs-boot has installed the libraries and runtime system for GHCJS"]
          ["ghcjs-boot will install the libraries and runtime system for GHCJS"]
    h "boot program"
    t "rl" [["ghcjs-boot program version", Info.getCompilerVersion]
           ,["file location", bootLoc]
           ,["last modified", show bootMod],[]
           ,["boot source location", bootSrc]
           ,["current directory", curDir]
           ]
    h "boot configuration"
    t "rl" [["installation directory", path $ beLocations . blGhcjsTopDir]
           ,["global package DB", path $ beLocations . blGlobalDB]
           ,["GHC version", ver "<unknown>" bpGhc]
           ,["location", loc bpGhc]
           ,["cabal-install version", ver "<unknown>" bpCabal]
           ,["location", loc bpCabal],[]
           ]
    h "packages"
    p ["stage 1a"] >> l (stg bstStage1a)
    p ["ghcjs-prim:  " ++ be ^. beStages . bstGhcjsPrim . to str]
    p ["stage 1b"] >> l (stg bstStage1b)
    p ["Cabal:  " ++ be ^. beStages . bstCabal . to str]
  section "Configured programs" $
    t "hlll" $ ["program", "version", "location"] :
      be ^.. bePrograms .
             (template :: Traversal' BootPrograms Program) .
             to pgm
  when after $ do
     p ["GHCJS has been booted."]
     p ["You can now add the binaries directory to your PATH, or create"]
     p ["symbolic to the ghcjs and ghcjs-pkg executables"]
     p ["the binaries have been installed in"]
     p [path $ beLocations . blGhcjsTopDir . to (</> "bin")]

  where
    stg s       = be ^.. beStages . s . traverse . to str
    h xs        = b >>
                  mapM_ (putStrLn . indent 2)
                        [xs, replicate (length xs) '-'] >> b
    p xs        = mapM_ (putStrLn . indent 3) xs >> b
    l xs        = mapM_ (putStrLn . indent 3 . ("- "++)) xs >> b
    t :: String -> [[String]] -> IO ()
    t aln xxs   = let colWidths = map (foldl' (\m xs -> max m (length xs)) 0)
                                      (transpose xxs)
                      (colAlign,hdr) = case aln of
                        ('h':a) -> (a, True)
                        a       -> (a, False)
                      cell w a xs = let pad = sp (w - length xs)
                                    in if a == 'r' then pad ++ xs
                                                   else xs ++ pad
                      cols xs   = sp 3 ++ intercalate (sp 3) xs
                      row xs    = cols (zipWith3 cell colWidths colAlign xs)
                  in case (xxs, hdr) of
                      (x:ys, True) -> putStrLn (row x) >>
                                      putStrLn (cols $ map sp colWidths) >>
                                      mapM_ (putStrLn . row) ys >> b
                      _            -> mapM_ (putStrLn . row) xxs
    b           = putStrLn ""
    sp n        = replicate n ' '
    indent n xs = sp n ++ xs
    sep         = putStrLn (replicate 75 '=')
    section :: String -> IO () -> IO ()
    section t a = b >> b >> sep >> b >> p [t] >> sep >> b >> a >> b
    ver d l     = be ^. bePrograms . l . pgmVersion . to (maybe d T.unpack)
    loc l       = be ^. bePrograms . l . pgmLocString
    path l      = be ^. l
    str         = T.unpack
    pgm x       = [ x ^. pgmName . to str
                  , maybe "-" T.unpack (x ^. pgmVersion)
                  , x ^. pgmLocString
                  ]

-- | boot.yaml
bootConfigFile :: BootSettings -> IO B.ByteString
bootConfigFile bs = do
  sourceDir <- bootSourceDir bs
  let sourceDir' = sourceDir
  e <- doesFileExist sourceDir'
  if e then do -- it's a tar file
         entries <- Tar.read . BL.fromStrict <$>
           B.readFile sourceDir'
         pure (BL.toStrict $ getBootYaml entries)
       else B.readFile (sourceDir </> "boot" <.> "yaml")
  where
    getBootYaml (Tar.Next e es)
      | Tar.entryPath e == "boot/boot.yaml"
      , Tar.NormalFile contents _size <- Tar.entryContent e = contents
      | otherwise = getBootYaml es
    getBootYaml Tar.Done     = error "boot/boot.yaml file not found in archive"
    getBootYaml (Tar.Fail e) = error $ "error reading boot archive: " ++ show e

bootSourceDir :: BootSettings -> IO FilePath
bootSourceDir bs
  | Just dd <- bs ^. bsSourceDir = makeAbsolute (T.unpack dd)
  | otherwise                    = do
      workingDirectory <- getCurrentDirectory
      let configFile =  workingDirectory </> "boot" <.> "yaml"
      configInCurrentDir <- doesFileExist configFile
      if configInCurrentDir
        then pure workingDirectory
        else do
          dataDir <- Info.ghcjsBootDefaultDataDir
          let bootArchive = dataDir </> "boot" <.> "tar"
          bootArchiveExists <- doesFileExist bootArchive
          pure $ if bootArchiveExists then bootArchive else workingDirectory

-- | our boot monad, we wrap around shelly but with a config environment
--   shelly commands are wrapped with logging
type B = ReaderT BootEnv IO

msg' :: BootSettings -> Verbosity -> Text -> IO ()
msg' bs v t = when (bs ^. bsVerbosity >= v) (T.putStrLn t)

msg :: Verbosity -> Text -> B ()
msg v t =
  view beSettings >>= \s -> when (s ^. bsVerbosity >= v) $ lift (T.putStrLn t)

-- | log a message printing the current directory
msgD :: Verbosity -> Text -> B ()
msgD v t = pwd >>= \p -> msg v (T.pack p <> "$ " <> t)

msgD' :: BootSettings -> Verbosity -> Text -> IO ()
msgD' bs v t = getCurrentDirectory >>= \p -> msg' bs v (T.pack p <> "$ " <> t)

{-
  lifted versions of the shelly operations we need. everything that
  makes externally visible changes is logged at the info (-v2)
  verbosity level.

  internal changes and file reads are logged at trace (-v3) level.
 -}

mkdir_p :: FilePath -> B ()
mkdir_p p      = msgD info ("mkdir_p " <> T.pack p) >> lift (createDirectoryIfMissing True p)

cp :: FilePath -> FilePath -> B ()
cp f t         = msgD info ("cp "      <> T.pack f <> " -> " <> T.pack t) >>
                 lift (copyFile f t)

cp_r :: FilePath -> FilePath -> B ()
cp_r src tgt = do
  liftIO (createDirectoryIfMissing True tgt)
  mapM_ f =<< liftIO (listDirectory src)
  where
    f entry = do
      let se = src </> entry
          te = tgt </> entry
      isDir <- liftIO (doesDirectoryExist se)
      if isDir then cp_r se te else liftIO (copyFile se te)

rm_rf :: FilePath -> B ()
rm_rf p        = msgD info ("rm_rf "   <> T.pack p) >> lift (removePathForcibly p)

cd :: FilePath -> B ()
cd p = do
  msgD trace ("cd " <> T.pack p)
  cur <- lift getCurrentDirectory
  lift (setCurrentDirectory (cur </> p))


sub :: B a -> B a
sub x = do
  workingDir <- liftIO getCurrentDirectory
  r <- x
  liftIO (setCurrentDirectory workingDir)
  pure r

run_ :: Program -> [Text] -> B ()
run_ p xs = do
  traceDir
  msgD info (traceRun p xs)
  requirePgmLoc p >>= \loc -> do
    let pc = proc loc (map T.unpack $ p ^. pgmArgs ++ xs)
    (_, _, _, ph) <- liftIO (createProcess pc)
    ex <- liftIO (waitForProcess ph)
    when (ex /= ExitSuccess)
       (failWith $ "program " <>
                   p ^. pgmLocText <>
                   " returned a nonzero exit code")

run'' :: FilePath -> Text -> [Text] -> B Text
run'' loc stdin xs = do
  msgD info (traceRun' loc xs)
  let pc = proc loc (map T.unpack xs)
  T.pack <$> lift (readCreateProcess pc (T.unpack stdin))

run''_ :: FilePath -> [Text] -> B ()
run''_ loc xs = do
  msgD info (traceRun' loc xs)
  let pc = proc loc (map T.unpack xs)
  (_, _, _, ph) <- liftIO (createProcess pc)
  ex <- liftIO (waitForProcess ph)
  when (ex /= ExitSuccess)
      (failWith $ "program " <>
                  T.pack loc <>
                  " returned a nonzero exit code")

readBinary :: FilePath -> B B.ByteString
readBinary path = do
  msgD trace ("reading " <> T.pack path)
  liftIO (B.readFile path)

pwd :: B FilePath
pwd = lift getCurrentDirectory


findWhen :: (FilePath -> B Bool) -> FilePath -> B [FilePath]
findWhen pred path = fmap concat (mapM f =<< (liftIO $ listDirectory path))
  where
    f :: FilePath -> B [FilePath]
    f entry = do
      let pe = path </> entry
      d <- liftIO (doesDirectoryExist pe)
      if d then findWhen pred pe
           else do
             pp <- pred pe
             if pp then pure [pe] else pure []

catchAny :: B b -> (Ex.SomeException -> B b) -> B b
catchAny a h = ask >>=
               \e -> lift (Ex.catch (runReaderT a e)
                                    (\ex -> runReaderT (h ex) e))

catchAny_ :: B b -> B b -> B b
catchAny_ a h  = catchAny a (\_ -> h)

traceDir :: B ()
traceDir = ask >>= \e -> lift (traceDir' (e ^. beSettings))

traceDir' :: BootSettings -> IO ()
traceDir' bs = do
  cur <- getCurrentDirectory
  msgD' bs info ("current directory: " <> T.pack cur)


traceRun :: Program -> [Text] -> Text
traceRun p xs = "[" <>
                p ^. pgmName <>
                "]: " <>
                p ^. pgmLocText <>
                " " <>
                T.intercalate " " (map (showT . T.unpack) xs)


traceRun' :: FilePath -> [Text] -> Text
traceRun' p xs = {- "[" <>
                  T.pack p <>
                "]: " <> -}
                T.pack p <>
                " " <>
                T.intercalate " " (map (showT . T.unpack) xs)

requirePgmLoc :: Program -> B FilePath
requirePgmLoc p
  | Just loc <- p ^. pgmLoc = return loc
  | otherwise = do
        {- search in original path, where we configured the programs.
           the shelly path might be local -}
        path <- fromMaybe "" <$> liftIO (Utils.getEnvMay "PATH")
        failWith $ "program " <>
                   p ^. pgmName <>
                   " is required but was not found\n" <>
                   "  name searched for (from boot.yaml or command line): " <>
                   p ^. pgmSearch <>
                   "\n" <>
                   "  searched in PATH:\n" <>
                   T.pack path

pgmLocText :: Getter Program Text
pgmLocText = pgmLoc . to (maybe "<not found>" T.pack)

pgmLocString :: Getter Program String
pgmLocString = pgmLocText . to T.unpack

showT :: Show a => a -> Text
showT = T.pack . show

bool :: Bool -> a -> a -> a
bool b t f = if b then t else f

bj :: Bool -> a -> Maybe a
bj b v = if b then Just v else Nothing

infixl 2 <^>
(<^>) :: MonadReader s m
      => (a -> m b)
      -> Getting a s a
      -> m b
(<^>) m l = m =<< view l