hsenv-0.5: src/Actions.hs

module Actions ( cabalUpdate
               , installCabalConfig
               , installCabalWrapper
               , installActivateScript
               , installSimpleWrappers
               , installProgSymlinks
               , symlinkToSkeleton
               , copyBaseSystem
               , initGhcDb
               , installGhc
               , createDirStructure
               ) where

import Control.Monad
import System.Directory (setCurrentDirectory, getCurrentDirectory, createDirectory, removeDirectoryRecursive, getAppUserDataDirectory, doesFileExist, findExecutable)
import System.FilePath ((</>))
import System.Info (arch, os)
import System.Posix hiding (createDirectory, version)
import Distribution.Version (Version (..))
import Distribution.Package (PackageName(..))
import Safe (lastMay)
import Data.List (intercalate)
import Data.Maybe (fromMaybe, isJust)

import Network.Http.Client
import qualified Data.ByteString.Char8 as C8
import qualified System.IO.Streams as S

import HsenvMonad
import Types
import Paths
import PackageManagement
import Process
import Util.Template (substs)
import Util.IO (makeExecutable, createTemporaryDirectory)
import Skeletons

-- update cabal package info inside Virtual Haskell Environment
cabalUpdate :: Hsenv ()
cabalUpdate = do
  noSharingFlag <- asks noSharing
  if noSharingFlag then do
    debug "Sharing user-wide ~/.cabal/packages disabled"
    cabalUpdate'
   else do
    debug "Sharing user-wide ~/.cabal/packages enabled, checking if data is already downloaded"
    cabalInstallDir <- liftIO $ getAppUserDataDirectory "cabal"
    let hackageData = foldl (</>) cabalInstallDir [ "packages"
                                                  , "hackage.haskell.org"
                                                  , "00-index.tar"
                                                  ]
    dataExists <- liftIO $ doesFileExist hackageData
    if dataExists then do
      info "Skipping 'cabal update' step, Hackage download cache already downloaded"
      info "  to ~/.cabal/packages/. You can update it manually with 'cabal update'"
      info "  (from inside or outside the virtual environment)."
     else do
      debug "No user-wide Hackage cache data downloaded"
      cabalUpdate'
      where cabalUpdate' = do
              cabalConfig <- cabalConfigLocation
              info "Updating cabal package database inside Virtual Haskell Environment."
              _ <- indentMessages $ insideProcess "cabal" ["--config-file=" ++ cabalConfig, "update"] Nothing
              return ()


-- install cabal wrapper (in bin/ directory) inside virtual environment dir structure
installCabalWrapper :: Hsenv ()
installCabalWrapper = do
  cabalConfig  <- cabalConfigLocation
  dirStructure <- hseDirStructure
  hsEnvName'   <- asks hsEnvName
  let cabalWrapper = hsEnvBinDir dirStructure </> "cabal"
  info $ concat [ "Installing cabal wrapper using "
                , cabalConfig
                , " at "
                , cabalWrapper
                ]
  let cabalWrapperContents = substs [ ("<CABAL_CONFIG>", cabalConfig)
                                    , ("<HSENV_NAME>", fromMaybe "" hsEnvName')] cabalWrapperSkel
  indentMessages $ do
    trace "cabal wrapper contents:"
    indentMessages $ mapM_ trace $ lines cabalWrapperContents
  liftIO $ writeFile cabalWrapper cabalWrapperContents
  liftIO $ makeExecutable cabalWrapper

installActivateScriptSupportFiles :: Hsenv ()
installActivateScriptSupportFiles = do
  debug "installing supporting files"
  dirStructure <- hseDirStructure
  ghc          <- asks ghcSource
  indentMessages $ do
    let pathVarPrependixLocation = hsEnvDir dirStructure </> "path_var_prependix"
        pathVarElems =
            case ghc of
              System -> [hsEnvBinDir dirStructure, cabalBinDir dirStructure]
              _      -> [ hsEnvBinDir dirStructure
                        , cabalBinDir dirStructure
                        , ghcBinDir dirStructure
                        ]
        pathVarPrependix = intercalate ":" pathVarElems
    debug $ "installing path_var_prependix file to " ++ pathVarPrependixLocation
    indentMessages $ trace $ "path_var_prependix contents: " ++ pathVarPrependix
    liftIO $ writeFile pathVarPrependixLocation pathVarPrependix
    ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation
    let ghcPackagePathVarLocation = hsEnvDir dirStructure </> "ghc_package_path_var"
        ghcPackagePathVar         = ghcPkgDbPath
    debug $ "installing ghc_package_path_var file to " ++ ghcPackagePathVarLocation
    indentMessages $ trace $ "path_var_prependix contents: " ++ ghcPackagePathVar
    liftIO $ writeFile ghcPackagePathVarLocation ghcPackagePathVar

-- install activate script (in bin/ directory) inside virtual environment dir structure
installActivateScript :: Hsenv ()
installActivateScript = do
  info "Installing activate script"
  hsEnvName'   <- asks hsEnvName
  noModifyPS1  <- asks noPS1
  dirStructure <- hseDirStructure
  ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation
  let activateScript = hsEnvBinDir dirStructure </> "activate"
  indentMessages $ debug $ "using location: " ++ activateScript
  let activateScriptContents =
          substs [ ("<HSENV_NAME>", fromMaybe "" hsEnvName')
                 , ("<HSENV_DIR>", hsEnvDir dirStructure)
                 , ("<HSENV>", hsEnv dirStructure)
                 , ("<GHC_PACKAGE_PATH>", ghcPkgDbPath)
                 , ("<HSENV_BIN_DIR>", hsEnvBinDir dirStructure)
                 , ("<CABAL_BIN_DIR>", cabalBinDir dirStructure)
                 , ("<GHC_BIN_DIR>", ghcBinDir dirStructure)
                 , ("<MODIFY_PS1>", if noModifyPS1 then "false" else "true")
                 ] activateSkel
  indentMessages $ do
    trace "activate script contents:"
    indentMessages $ mapM_ trace $ lines activateScriptContents
  liftIO $ writeFile activateScript activateScriptContents
  indentMessages installActivateScriptSupportFiles

-- install cabal's config file (in cabal/ directory) inside virtual environment dir structure
installCabalConfig :: Hsenv ()
installCabalConfig = do
  cabalConfig  <- cabalConfigLocation
  dirStructure <- hseDirStructure
  noSharingFlag  <- asks noSharing
  hackageCache <- indentMessages $
      if noSharingFlag then do
          info "Using private Hackage download cache directory"
          return $ cabalDir dirStructure </> "packages"
      else do
          info "Using user-wide (~/.cabal/packages) Hackage download cache directory"
          cabalInstallDir <- liftIO $ getAppUserDataDirectory "cabal"
          return $ cabalInstallDir </> "packages"
  info $ "Installing cabal config at " ++ cabalConfig
  let cabalConfigContents = substs [ ("<GHC_PACKAGE_PATH>", ghcPackagePath dirStructure)
                                   , ("<CABAL_DIR>", cabalDir dirStructure)
                                   , ("<HACKAGE_CACHE>", hackageCache)
                                   ] cabalConfigSkel
  indentMessages $ do
    trace "cabal config contents:"
    indentMessages $ mapM_ trace $ lines cabalConfigContents
  liftIO $ writeFile cabalConfig cabalConfigContents

installSimpleWrappers :: Hsenv ()
installSimpleWrappers = mapM_ installSimpleWrapper simpleWrappers

installSimpleWrapper :: (String, String) -> Hsenv ()
installSimpleWrapper (targetFilename, skeleton) = do
    ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation
    dirStructure <- hseDirStructure
    let ghcWrapperContents =
            substs [("<GHC_PACKAGE_PATH>", ghcPkgDbPath)] skeleton
        ghcWrapper = hsEnvBinDir dirStructure </> targetFilename
    liftIO $ writeFile ghcWrapper ghcWrapperContents
    liftIO $ makeExecutable ghcWrapper

installProgSymlinks :: Hsenv ()
installProgSymlinks = mapM_ installSymlink extraProgs

extraProgs :: [String]
extraProgs = [ "alex"
             , "ar"
             , "c2hs"
             , "cpphs"
             , "ffihugs"
             , "gcc"
             , "greencard"
             , "haddock"
             , "happy"
             , "hmake"
             , "hpc"
             , "hsc2hs"
             , "hscolour"
             , "hugs"
             , "jhc"
             , "ld"
             , "lhc"
             , "lhc-pkg"
             , "nhc98"
             , "pkg-config"
             , "ranlib"
             , "strip"
             , "tar"
             , "uhc"
             ]

installSymlink :: String -> Hsenv ()
installSymlink prog = do
    dirStructure <- hseDirStructure
    ghcSourceOpt <- asks ghcSource
    mPrivateLoc <- case ghcSourceOpt of
        System -> return Nothing
        _      -> liftIO $ findExecutable $ ghcDir dirStructure </> "bin" </> prog
    mSystemLoc <- liftIO $ findExecutable prog
    let mProgLoc = mPrivateLoc `mplus` mSystemLoc
    when (isJust mProgLoc) $ do
        let Just progLoc = mProgLoc
        liftIO $ createSymbolicLink progLoc $ hsEnvBinDir dirStructure </> prog

-- | Install a symbolic link to a skeleton script in hsenv's bin directory
symlinkToSkeleton :: String -- ^ Name of skeleton
                  -> String -- ^ Name of link
                  -> Hsenv ()
symlinkToSkeleton skel link = do
    dirStructure <- hseDirStructure
    let prependBinDir = (hsEnvBinDir dirStructure </>)
    liftIO $ createSymbolicLink (prependBinDir skel) (prependBinDir link)

createDirStructure :: Hsenv ()
createDirStructure = do
  dirStructure <- hseDirStructure
  info "Creating Virtual Haskell directory structure"
  indentMessages $ do
    debug $ "hsenv directory: " ++ hsEnvDir dirStructure
    liftIO $ createDirectory $ hsEnvDir dirStructure
    debug $ "cabal directory: " ++ cabalDir dirStructure
    liftIO $ createDirectory $ cabalDir dirStructure
    debug $ "hsenv bin directory: " ++ hsEnvBinDir dirStructure
    liftIO $ createDirectory $ hsEnvBinDir dirStructure

-- initialize private GHC package database inside virtual environment
initGhcDb :: Hsenv ()
initGhcDb = do
  dirStructure <- hseDirStructure
  info $ "Initializing GHC Package database at " ++ ghcPackagePath dirStructure
  out <- indentMessages $ outsideGhcPkg ["--version"]
  case lastMay $ words out of
    Nothing            -> throwError $ HsenvException $ "Couldn't extract ghc-pkg version number from: " ++ out
    Just versionString -> do
      indentMessages $ trace $ "Found version string: " ++ versionString
      version <- parseVersion versionString
      let ghc_6_12_1_version = Version [6,12,1] []
      if version < ghc_6_12_1_version then do
        indentMessages $ debug "Detected GHC older than 6.12, initializing GHC_PACKAGE_PATH to file with '[]'"
        liftIO $ writeFile (ghcPackagePath dirStructure) "[]"
       else do
        _ <- indentMessages $ outsideGhcPkg ["init", ghcPackagePath dirStructure]
        return ()

-- copy optional packages and don't fail completely if this copying fails
-- some packages mail fail to copy and it's not fatal (e.g. older GHCs don't have haskell2010)
transplantOptionalPackage :: String -> Hsenv ()
transplantOptionalPackage name = transplantPackage (PackageName name) `catchError` handler
  where handler e = do
          warning $ "Failed to copy optional package " ++ name ++ " from system's GHC: "
          indentMessages $ warning $ getExceptionMessage e

-- copy base system
-- base - needed for ghci and everything else
-- Cabal - needed to install non-trivial cabal packages with cabal-install
-- haskell98 - some packages need it but they don't specify it (seems it's an implicit dependancy)
-- haskell2010 - maybe it's similar to haskell98?
-- ghc and ghc-binary - two packages that are provided with GHC and cannot be installed any other way
-- also include dependant packages of all the above
-- when using GHC from tarball, just reuse its package database
-- cannot do the same when using system's GHC, because there might be additional packages installed
-- then it wouldn't be possible to work on them insie virtual environment
copyBaseSystem :: Hsenv ()
copyBaseSystem = do
  info "Copying necessary packages from original GHC package database"
  indentMessages $ do
    ghc <- asks ghcSource
    case ghc of
      System -> do
        transplantPackage $ PackageName "base"
        transplantPackage $ PackageName "Cabal"
        mapM_ transplantOptionalPackage ["haskell98", "haskell2010", "ghc", "ghc-binary"]
      _ -> debug "Using external GHC - nothing to copy, Virtual environment will reuse GHC package database"

installGhc :: Hsenv ()
installGhc = do
  info "Installing GHC"
  ghc <- asks ghcSource
  case ghc of
    System              -> indentMessages $ debug "Using system version of GHC - nothing to install."
    Tarball tarballPath -> indentMessages $ installExternalGhc tarballPath
    Url url             -> indentMessages $ installRemoteGhc url
    Release tag         -> indentMessages $ installReleasedGhc tag

installExternalGhc :: FilePath -> Hsenv ()
installExternalGhc tarballPath = do
  info $ "Installing GHC from " ++ tarballPath
  indentMessages $ do
    dirStructure <- hseDirStructure
    tmpGhcDir <- liftIO $ createTemporaryDirectory (hsEnv dirStructure) "ghc"
    debug $ "Unpacking GHC tarball to " ++ tmpGhcDir
    _ <- indentMessages $ outsideProcess' "tar" ["xf", tarballPath, "-C", tmpGhcDir, "--strip-components", "1"]
    let configureScript = tmpGhcDir </> "configure"
    debug $ "Configuring GHC with prefix " ++ ghcDir dirStructure
    cwd <- liftIO getCurrentDirectory
    liftIO $ setCurrentDirectory tmpGhcDir
    make <- asks makeCmd
    let configureAndInstall = do
          _ <- indentMessages $ outsideProcess' configureScript ["--prefix=" ++ ghcDir dirStructure]
          debug $ "Installing GHC with " ++ make ++ " install"
          _ <- indentMessages $ outsideProcess' make ["install"]
          return ()
    configureAndInstall `finally` liftIO (setCurrentDirectory cwd)
    liftIO $ removeDirectoryRecursive tmpGhcDir
    return ()

-- Download a file over HTTP using streams, so it
-- has constant memory allocation.
downloadFile :: URL -> FilePath -> Hsenv ()
downloadFile url name = do
  m_ex <- liftIO $ get url $ \response inStream ->
    case getStatusCode response of
      200 -> S.withFileAsOutput name (S.connect inStream) >> return Nothing
      code -> return $ Just $ HsenvException $
        "Failed to download "
          ++ name
          ++ ": http response returned "
          ++ show code
  maybe (return ()) throwError m_ex

installRemoteGhc :: String -> Hsenv ()
installRemoteGhc url = do
    dirStructure <- hseDirStructure
    downloadDir <- liftIO $ createTemporaryDirectory (hsEnv dirStructure) "ghc-download"
    let tarball = downloadDir </> "tarball"
    debug $ "Downloading GHC from " ++ url
    downloadFile (C8.pack url) tarball
    installExternalGhc tarball
    liftIO $ removeDirectoryRecursive downloadDir
    return ()

installReleasedGhc :: String -> Hsenv ()
installReleasedGhc tag = do
    let url = "http://www.haskell.org/ghc/dist/" ++ tag ++ "/ghc-" ++ tag ++ "-" ++ platform ++ ".tar.bz2"
    installRemoteGhc url

platform :: String
platform = intercalate "-" [arch, if os == "darwin" then "apple" else "unknown", os]