content: {-# LANGUAGE CPP #-}
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  Distribution.Client.InstallSymlink
  -- Copyright   :  (c) Duncan Coutts 2008
  -- License     :  BSD-like
  --
  -- Maintainer  :  cabal-devel@haskell.org
  -- Stability   :  provisional
  -- Portability :  portable
  --
  -- Managing installing binaries with symlinks.
  -----------------------------------------------------------------------------
  module Distribution.Client.InstallSymlink (
      symlinkBinaries,
      symlinkBinary,
    ) where
  
  #ifdef mingw32_HOST_OS
  
  import Distribution.Package (PackageIdentifier)
  import Distribution.Types.UnqualComponentName
  import Distribution.Client.InstallPlan (InstallPlan)
  import Distribution.Client.Types (BuildOutcomes)
  import Distribution.Client.Setup (InstallFlags)
  import Distribution.Simple.Setup (ConfigFlags)
  import Distribution.Simple.Compiler
  import Distribution.System
  
  symlinkBinaries :: Platform -> Compiler
                  -> ConfigFlags
                  -> InstallFlags
                  -> InstallPlan
                  -> BuildOutcomes
                  -> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
  symlinkBinaries _ _ _ _ _ _ = return []
  
  symlinkBinary :: FilePath -> FilePath -> UnqualComponentName -> String -> IO Bool
  symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"
  
  #else
  
  import Distribution.Client.Types
           ( ConfiguredPackage(..), BuildOutcomes )
  import Distribution.Client.Setup
           ( InstallFlags(installSymlinkBinDir) )
  import qualified Distribution.Client.InstallPlan as InstallPlan
  import Distribution.Client.InstallPlan (InstallPlan)
  
  import Distribution.Solver.Types.SourcePackage
  import Distribution.Solver.Types.OptionalStanza
  
  import Distribution.Package
           ( PackageIdentifier, Package(packageId), UnitId, installedUnitId )
  import Distribution.Types.UnqualComponentName
  import Distribution.Compiler
           ( CompilerId(..) )
  import qualified Distribution.PackageDescription as PackageDescription
  import Distribution.PackageDescription
           ( PackageDescription )
  import Distribution.PackageDescription.Configuration
           ( finalizePD )
  import Distribution.Simple.Setup
           ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe )
  import qualified Distribution.Simple.InstallDirs as InstallDirs
  import Distribution.Simple.Compiler
           ( Compiler, compilerInfo, CompilerInfo(..) )
  import Distribution.System
           ( Platform )
  import Distribution.Text
           ( display )
  
  import System.Posix.Files
           ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink
           , removeLink )
  import System.Directory
           ( canonicalizePath )
  import System.FilePath
           ( (</>), splitPath, joinPath, isAbsolute )
  
  import Prelude hiding (ioError)
  import System.IO.Error
           ( isDoesNotExistError, ioError )
  import Distribution.Compat.Exception ( catchIO )
  import Control.Exception
           ( assert )
  import Data.Maybe
           ( catMaybes )
  
  -- | We would like by default to install binaries into some location that is on
  -- the user's PATH. For per-user installations on Unix systems that basically
  -- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@
  -- directory will be on the user's PATH. However some people are a bit nervous
  -- about letting a package manager install programs into @~/bin/@.
  --
  -- A compromise solution is that instead of installing binaries directly into
  -- @~/bin/@, we could install them in a private location under @~/.cabal/bin@
  -- and then create symlinks in @~/bin/@. We can be careful when setting up the
  -- symlinks that we do not overwrite any binary that the user installed. We can
  -- check if it was a symlink we made because it would point to the private dir
  -- where we install our binaries. This means we can install normally without
  -- worrying and in a later phase set up symlinks, and if that fails then we
  -- report it to the user, but even in this case the package is still in an OK
  -- installed state.
  --
  -- This is an optional feature that users can choose to use or not. It is
  -- controlled from the config file. Of course it only works on POSIX systems
  -- with symlinks so is not available to Windows users.
  --
  symlinkBinaries :: Platform -> Compiler
                  -> ConfigFlags
                  -> InstallFlags
                  -> InstallPlan
                  -> BuildOutcomes
                  -> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
  symlinkBinaries platform comp configFlags installFlags plan buildOutcomes =
    case flagToMaybe (installSymlinkBinDir installFlags) of
      Nothing            -> return []
      Just symlinkBinDir
             | null exes -> return []
             | otherwise -> do
        publicBinDir  <- canonicalizePath symlinkBinDir
  --    TODO: do we want to do this here? :
  --      createDirectoryIfMissing True publicBinDir
        fmap catMaybes $ sequence
          [ do privateBinDir <- pkgBinDir pkg ipid
               ok <- symlinkBinary
                       publicBinDir  privateBinDir
                       publicExeName privateExeName
               if ok
                 then return Nothing
                 else return (Just (pkgid, publicExeName,
                                    privateBinDir </> privateExeName))
          | (rpkg, pkg, exe) <- exes
          , let pkgid  = packageId pkg
                -- This is a bit dodgy; probably won't work for Backpack packages
                ipid = installedUnitId rpkg
                publicExeName  = PackageDescription.exeName exe
                privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix
                prefix = substTemplate pkgid ipid prefixTemplate
                suffix = substTemplate pkgid ipid suffixTemplate ]
    where
      exes =
        [ (cpkg, pkg, exe)
        | InstallPlan.Configured cpkg <- InstallPlan.toList plan
        , case InstallPlan.lookupBuildOutcome cpkg buildOutcomes of
            Just (Right _success) -> True
            _                     -> False
        , let pkg :: PackageDescription
              pkg = pkgDescription cpkg
        , exe <- PackageDescription.executables pkg
        , PackageDescription.buildable (PackageDescription.buildInfo exe) ]
  
      pkgDescription (ConfiguredPackage _ (SourcePackage _ pkg _ _ _)
                                        flags stanzas _) =
        case finalizePD flags (enableStanzas stanzas)
               (const True)
               platform cinfo [] pkg of
          Left _ -> error "finalizePD ReadyPackage failed"
          Right (desc, _) -> desc
  
      -- This is sadly rather complicated. We're kind of re-doing part of the
      -- configuration for the package. :-(
      pkgBinDir :: PackageDescription -> UnitId -> IO FilePath
      pkgBinDir pkg ipid = do
        defaultDirs <- InstallDirs.defaultInstallDirs
                         compilerFlavor
                         (fromFlag (configUserInstall configFlags))
                         (PackageDescription.hasLibs pkg)
        let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
                             defaultDirs (configInstallDirs configFlags)
            absoluteDirs = InstallDirs.absoluteInstallDirs
                             (packageId pkg) ipid
                             cinfo InstallDirs.NoCopyDest
                             platform templateDirs
        canonicalizePath (InstallDirs.bindir absoluteDirs)
  
      substTemplate pkgid ipid = InstallDirs.fromPathTemplate
                               . InstallDirs.substPathTemplate env
        where env = InstallDirs.initialPathTemplateEnv pkgid ipid
                                                       cinfo platform
  
      fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")
      prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)
      suffixTemplate   = fromFlagTemplate (configProgSuffix configFlags)
      cinfo            = compilerInfo comp
      (CompilerId compilerFlavor _) = compilerInfoId cinfo
  
  symlinkBinary ::
    FilePath               -- ^ The canonical path of the public bin dir eg
                           --   @/home/user/bin@
    -> FilePath            -- ^ The canonical path of the private bin dir eg
                           --   @/home/user/.cabal/bin@
    -> UnqualComponentName -- ^ The name of the executable to go in the public bin
                           --   dir, eg @foo@
    -> String              -- ^ The name of the executable to in the private bin
                           --   dir, eg @foo-1.0@
    -> IO Bool             -- ^ If creating the symlink was successful. @False@ if
                           --   there was another file there already that we did
                           --   not own. Other errors like permission errors just
                           --   propagate as exceptions.
  symlinkBinary publicBindir privateBindir publicName privateName = do
    ok <- targetOkToOverwrite (publicBindir </> publicName')
                              (privateBindir </> privateName)
    case ok of
      NotOurFile    ->                     return False
      NotExists     ->           mkLink >> return True
      OkToOverwrite -> rmLink >> mkLink >> return True
    where
      publicName' = display publicName
      relativeBindir = makeRelative publicBindir privateBindir
      mkLink = createSymbolicLink (relativeBindir </> privateName)
                                  (publicBindir   </> publicName')
      rmLink = removeLink (publicBindir </> publicName')
  
  -- | Check a file path of a symlink that we would like to create to see if it
  -- is OK. For it to be OK to overwrite it must either not already exist yet or
  -- be a symlink to our target (in which case we can assume ownership).
  --
  targetOkToOverwrite :: FilePath -- ^ The file path of the symlink to the private
                                  -- binary that we would like to create
                      -> FilePath -- ^ The canonical path of the private binary.
                                  -- Use 'canonicalizePath' to make this.
                      -> IO SymlinkStatus
  targetOkToOverwrite symlink target = handleNotExist $ do
    status <- getSymbolicLinkStatus symlink
    if not (isSymbolicLink status)
      then return NotOurFile
      else do target' <- canonicalizePath symlink
              -- This relies on canonicalizePath handling symlinks
              if target == target'
                then return OkToOverwrite
                else return NotOurFile
  
    where
      handleNotExist action = catchIO action $ \ioexception ->
        -- If the target doesn't exist then there's no problem overwriting it!
        if isDoesNotExistError ioexception
          then return NotExists
          else ioError ioexception
  
  data SymlinkStatus
     = NotExists     -- ^ The file doesn't exist so we can make a symlink.
     | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll
                     -- have to delete it first before we make a new symlink.
     | NotOurFile    -- ^ A file already exists and it is not one of our existing
                     -- symlinks (either because it is not a symlink or because
                     -- it points somewhere other than our managed space).
    deriving Show
  
  -- | Take two canonical paths and produce a relative path to get from the first
  -- to the second, even if it means adding @..@ path components.
  --
  makeRelative :: FilePath -> FilePath -> FilePath
  makeRelative a b = assert (isAbsolute a && isAbsolute b) $
    let as = splitPath a
        bs = splitPath b
        commonLen = length $ takeWhile id $ zipWith (==) as bs
     in joinPath $ [ ".." | _  <- drop commonLen as ]
                ++ drop commonLen bs
  
  #endif
  