module GHC.Linker.Windows
   ( maybeCreateManifest
   )
where

import GHC.Prelude
import GHC.SysTools
import GHC.Driver.Session
import GHC.Utils.TmpFs
import GHC.Utils.Logger

import System.FilePath
import System.Directory

maybeCreateManifest
   :: Logger
   -> TmpFs
   -> DynFlags
   -> FilePath      -- ^ filename of executable
   -> IO [FilePath] -- ^ extra objects to embed, maybe
maybeCreateManifest :: Logger -> TmpFs -> DynFlags -> FilePath -> IO [FilePath]
maybeCreateManifest Logger
logger TmpFs
tmpfs DynFlags
dflags FilePath
exe_filename = do
   let manifest_filename :: FilePath
manifest_filename = FilePath
exe_filename FilePath -> FilePath -> FilePath
<.> FilePath
"manifest"
       manifest :: FilePath
manifest =
         FilePath
"<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n\
         \  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n\
         \  <assemblyIdentity version=\"1.0.0.0\"\n\
         \     processorArchitecture=\"X86\"\n\
         \     name=\"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
dropExtension FilePath
exe_filename FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\"\n\
         \     type=\"win32\"/>\n\n\
         \  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n\
         \    <security>\n\
         \      <requestedPrivileges>\n\
         \        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n\
         \        </requestedPrivileges>\n\
         \       </security>\n\
         \  </trustInfo>\n\
         \</assembly>\n"

   FilePath -> FilePath -> IO ()
writeFile FilePath
manifest_filename FilePath
manifest

   -- Windows will find the manifest file if it is named
   -- foo.exe.manifest. However, for extra robustness, and so that
   -- we can move the binary around, we can embed the manifest in
   -- the binary itself using windres:
   if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EmbedManifest DynFlags
dflags)
      then [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      else do
         FilePath
rc_filename <- Logger
-> TmpFs -> DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs DynFlags
dflags TempFileLifetime
TFL_CurrentModule FilePath
"rc"
         FilePath
rc_obj_filename <-
           Logger
-> TmpFs -> DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs DynFlags
dflags TempFileLifetime
TFL_GhcSession (DynFlags -> FilePath
objectSuf DynFlags
dflags)

         FilePath -> FilePath -> IO ()
writeFile FilePath
rc_filename (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
             FilePath
"1 24 MOVEABLE PURE " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
manifest_filename FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
               -- magic numbers :-)
               -- show is a bit hackish above, but we need to escape the
               -- backslashes in the path.

         Logger -> DynFlags -> [Option] -> IO ()
runWindres Logger
logger DynFlags
dflags ([Option] -> IO ()) -> [Option] -> IO ()
forall a b. (a -> b) -> a -> b
$ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option ([FilePath] -> [Option]) -> [FilePath] -> [Option]
forall a b. (a -> b) -> a -> b
$
               [FilePath
"--input="FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
rc_filename,
                FilePath
"--output="FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
rc_obj_filename,
                FilePath
"--output-format=coff"]
               -- no FileOptions here: windres doesn't like seeing
               -- backslashes, apparently

         FilePath -> IO ()
removeFile FilePath
manifest_filename

         [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
rc_obj_filename]