Enable automatic downloading of a binary distribution of GHC when cre…

…ating a new sandbox Closes #22 Merge branch 'ghc-urls'
tmhedberg · Mar 20, 2013 · 9664443 · 9664443
2 parents f070ce6 + 968badd
commit 9664443
Show file tree

Hide file tree

Showing 6 changed files with 51 additions and 16 deletions.
diff --git a/src/Actions.hs b/src/Actions.hs
@@ -14,6 +14,7 @@ module Actions ( cabalUpdate
 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(..))
@@ -88,11 +89,11 @@ installActivateScriptSupportFiles = do
     let pathVarPrependixLocation = hsEnvDir dirStructure </> "path_var_prependix"
         pathVarElems =
             case ghc of
-              System    -> [hsEnvBinDir dirStructure, cabalBinDir dirStructure]
-              Tarball _ -> [ hsEnvBinDir dirStructure
-                          , cabalBinDir dirStructure
-                          , ghcBinDir dirStructure
-                          ]
+              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
@@ -278,8 +279,7 @@ copyBaseSystem = do
         transplantPackage $ PackageName "base"
         transplantPackage $ PackageName "Cabal"
         mapM_ transplantOptionalPackage ["haskell98", "haskell2010", "ghc", "ghc-binary"]
-      Tarball _ ->
-        debug "Using external GHC - nothing to copy, Virtual environment will reuse GHC package database"
+      _ -> debug "Using external GHC - nothing to copy, Virtual environment will reuse GHC package database"
 
 installGhc :: MyMonad ()
 installGhc = do
@@ -288,6 +288,8 @@ installGhc = do
   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 -> MyMonad ()
 installExternalGhc tarballPath = do
@@ -310,3 +312,22 @@ installExternalGhc tarballPath = do
     configureAndInstall `finally` liftIO (setCurrentDirectory cwd)
     liftIO $ removeDirectoryRecursive tmpGhcDir
     return ()
+
+installRemoteGhc :: String -> MyMonad ()
+installRemoteGhc url = do
+    dirStructure <- hseDirStructure
+    downloadDir <- liftIO $ createTemporaryDirectory (hsEnv dirStructure) "ghc-download"
+    let tarball = downloadDir </> "tarball"
+    debug $ "Downloading GHC from " ++ url
+    _ <- indentMessages $ outsideProcess' "curl" ["-fL", "--retry", "2", url, "-o", tarball]
+    installExternalGhc tarball
+    liftIO $ removeDirectoryRecursive downloadDir
+    return ()
+
+installReleasedGhc :: String -> MyMonad ()
+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]
diff --git a/src/Args.hs b/src/Args.hs
@@ -3,6 +3,7 @@
 module Args (getArgs) where
 
 import Control.Arrow
+import Data.Char
 import Util.Args
 import Types
 
@@ -57,10 +58,10 @@ nameOpt = DynOpt
 
 ghcOpt = DynOpt
          { dynOptName = "ghc"
-         , dynOptTemplate = "FILE"
+         , dynOptTemplate = "VERSION|URL|FILE"
          , dynOptDescription = "system's copy of GHC"
          , dynOptHelp =
-             "Use GHC from provided tarball (e.g. ghc-7.0.4-i386-unknown-linux.tar.bz2)"
+             "Use GHC from provided location -- a GHC version number, an HTTP or HTTPS URL or a path to a tarball (e.g. ghc-7.0.4-i386-unknown-linux.tar.bz2)"
          }
 
 makeOpt :: StaticOpt
@@ -85,7 +86,12 @@ argParser = proc () -> do
   noPS1' <- getOpt noPS1Opt -< ()
   let ghc = case ghcFlag of
               Nothing   -> System
-              Just path -> Tarball path
+              -- First check for URLs (@//@ is not meaningful in Posix file
+              -- paths), then versions and then default to path.
+              Just s | "https://" == take 8 s -> Url s
+                     | "http://"  == take 7 s -> Url s
+                     | isVersion s            -> Release s
+                     | otherwise              -> Tarball s
   skipSanityCheckFlag <- getOpt skipSanityOpt -< ()
   noSharingFlag <- getOpt sharingOpt -< ()
   make <- getOpt makeOpt -< ()
@@ -102,3 +108,9 @@ getArgs :: IO Options
 getArgs = parseArgs argParser versionString outro
     where outro = "Creates Virtual Haskell Environment in the current directory.\n"
                   ++ "All files will be stored in the .hsenv_ENVNAME/ subdirectory."
+
+isVersion :: String -> Bool
+isVersion s = case dropWhile isDigit s of
+                ""     -> s /= ""
+                '.':s' -> s /= '.':s' && isVersion s'
+                _      -> False
diff --git a/src/Paths.hs b/src/Paths.hs
@@ -58,6 +58,6 @@ insidePathVar = do
   dirStructure <- hseDirStructure
   ghc          <- asks ghcSource
   let extraPathElems = case ghc of
-                         System    -> [cabalBinDir dirStructure]
-                         Tarball _ -> [cabalBinDir dirStructure, ghcBinDir dirStructure]
+                         System -> [cabalBinDir dirStructure]
+                         _      -> [cabalBinDir dirStructure, ghcBinDir dirStructure]
   return $ intercalate ":" extraPathElems ++ oldPathVarSuffix
diff --git a/src/Process.hs b/src/Process.hs
@@ -100,8 +100,8 @@ ghcPkgDbPathLocation = do
   dirStructure <- hseDirStructure
   ghc <- asks ghcSource
   case ghc of
-    System    -> return $ ghcPackagePath dirStructure
-    Tarball _ -> do
+    System -> return $ ghcPackagePath dirStructure
+    _      -> do
              externalGhcPkgDbPath <- indentMessages externalGhcPkgDb
              return $ ghcPackagePath dirStructure ++ ":" ++ externalGhcPkgDbPath
 

diff --git a/src/SanityCheck.hs b/src/SanityCheck.hs
@@ -44,8 +44,7 @@ checkGhc :: MyMonad ()
 checkGhc = do
   ghcSrc <- asks ghcSource
   case ghcSrc of
-    Tarball _ -> return ()
-    System    -> do
+    System -> do
       ghcPath <- liftIO $ which Nothing "ghc"
       case ghcPath of
         Just _  -> return ()
@@ -54,6 +53,7 @@ checkGhc = do
       case ghc_pkgPath of
         Just _  -> return ()
         Nothing -> throwError $ MyException "Couldn't find ghc-pkg binary in your $PATH."
+    _      -> return ()
 
 -- check if everything is sane
 sanityCheck :: MyMonad ()

diff --git a/src/Types.hs b/src/Types.hs
@@ -11,6 +11,8 @@ import Control.Monad.Error (Error)
 
 data GhcSource = System           -- Use System's copy of GHC
                | Tarball FilePath -- Use GHC from tarball
+               | Url String       -- Use GHC downloadable at URL
+               | Release String   -- Infer a URL and use GHC from there
 
 data Verbosity = Quiet
                | Verbose