Use cabal dependency solver as a last resort #116

src/Stack/Init.hs

@@ -11,10 +11,9 @@ module Stack.Init
     ) where
 
 import           Control.Exception               (assert)
-import           Control.Exception.Enclosed      (handleIO)
+import           Control.Exception.Enclosed      (handleIO, tryAny, catchAny)
 import           Control.Monad                   (liftM, when)
-import           Control.Monad.Catch             (MonadCatch, SomeException,
-                                                  catch, throwM)
+import           Control.Monad.Catch             (MonadMask, throwM)
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
 import           Control.Monad.Reader            (MonadReader)
@@ -40,6 +39,7 @@ import           Path.IO
 import           Stack.BuildPlan
 import           Stack.Constants
 import           Stack.Package
+import           Stack.Solver
 import           Stack.Types
 import           System.Directory                (getDirectoryContents)
 
@@ -60,7 +60,7 @@ ignoredDirs = Set.fromList
     ]
 
 -- | Generate stack.yaml
-initProject :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
+initProject :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
             => Maybe Resolver -- ^ force this resolver to be used
             -> InitOpts
             -> m ()
@@ -80,10 +80,10 @@ initProject mresolver initOpts = do
     when (null cabalfps) $ error "In order to init, you should have an existing .cabal file. Please try \"stack new\" instead"
     gpds <- mapM readPackageUnresolved cabalfps
 
-    (r, flags) <- getDefaultResolver gpds mresolver initOpts
+    (r, flags, extraDeps) <- getDefaultResolver cabalfps gpds mresolver initOpts
     let p = Project
             { projectPackages = pkgs
-            , projectExtraDeps = Map.empty
+            , projectExtraDeps = extraDeps
             , projectFlags = flags
             , projectResolver = r
             }
@@ -102,10 +102,10 @@ initProject mresolver initOpts = do
     liftIO $ Yaml.encodeFile dest' p
     $logInfo $ "Wrote project config to: " <> T.pack dest'
 
-getSnapshots' :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
-              => m Snapshots
+getSnapshots' :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
+              => m (Maybe Snapshots)
 getSnapshots' =
-    getSnapshots `catch` \e -> do
+    liftM Just getSnapshots `catchAny` \e -> do
         $logError $
             "Unable to download snapshot list, and therefore could " <>
             "not generate a stack.yaml file automatically"
@@ -119,20 +119,25 @@ getSnapshots' =
         $logError ""
         $logError "    https://github.com/commercialhaskell/stack/wiki/stack.yaml"
         $logError ""
-        throwM (e :: SomeException)
+        $logError $ "Exception was: " <> T.pack (show e)
+        return Nothing
 
 -- | Get the default resolver value
-getDefaultResolver :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
-                   => [C.GenericPackageDescription] -- ^ cabal files
+getDefaultResolver :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
+                   => [Path Abs File] -- ^ cabal files
+                   -> [C.GenericPackageDescription] -- ^ cabal descriptions
                    -> Maybe Resolver -- ^ resolver override
                    -> InitOpts
-                   -> m (Resolver, Map PackageName (Map FlagName Bool))
-getDefaultResolver gpds mresolver initOpts = do
+                   -> m (Resolver, Map PackageName (Map FlagName Bool), Map PackageName Version)
+getDefaultResolver cabalfps gpds mresolver initOpts = do
     names <-
         case mresolver of
+            Nothing | ioUseSolver initOpts -> return []
             Nothing -> do
-                snapshots <- getSnapshots'
-                getRecommendedSnapshots snapshots initOpts
+                msnapshots <- getSnapshots'
+                case msnapshots of
+                    Nothing -> return []
+                    Just snapshots -> getRecommendedSnapshots snapshots initOpts
             Just resolver ->
                 return $
                     case resolver of
@@ -141,16 +146,27 @@ getDefaultResolver gpds mresolver initOpts = do
     mpair <- findBuildPlan gpds names
     case mpair of
         Just (snap, flags) ->
-            return (ResolverSnapshot snap, flags)
+            return (ResolverSnapshot snap, flags, Map.empty)
         Nothing ->
             case mresolver of
                 Nothing ->
                     case ioFallback initOpts of
-                        Nothing -> throwM $ NoMatchingSnapshot names
-                        Just resolver -> return (resolver, Map.empty)
-                Just resolver -> return (resolver, Map.empty)
-
-getRecommendedSnapshots :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
+                        Nothing -> do
+                            eres <- tryAny $ cabalSolver cabalfps
+                            case eres of
+                                Left e -> do
+                                    $logInfo $ T.pack $ "Using cabal solver failed: " ++ show e
+                                    throwM $ NoMatchingSnapshot names
+                                Right (ghcVersion, extraDeps) -> do
+                                    return
+                                        ( ResolverGhc ghcVersion
+                                        , Map.filter (not . Map.null) $ fmap snd extraDeps
+                                        , fmap fst extraDeps
+                                        )
+                        Just resolver -> return (resolver, Map.empty, Map.empty)
+                Just resolver -> return (resolver, Map.empty, Map.empty)
+
+getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
                         => Snapshots
                         -> InitOpts
                         -> m [SnapName]
@@ -188,6 +204,8 @@ data InitOpts = InitOpts
     { ioPref     :: !SnapPref
     -- ^ Preferred snapshots
     , ioFallback :: !(Maybe Resolver)
+    , ioUseSolver :: !Bool
+    -- ^ Force usage of a dependency solver instead of snapshots
     }
 
 data SnapPref = PrefNone | PrefLTS | PrefNightly
@@ -196,6 +214,9 @@ initOptsParser :: Parser InitOpts
 initOptsParser = InitOpts
     <$> pref
     <*> optional fallback
+    <*> flag False True
+            (long "use-solver" <>
+             help "Force usage of a dependency solver")
   where
     pref =
         flag' PrefLTS

src/Stack/Solver.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TemplateHaskell       #-}
+module Stack.Solver
+    ( cabalSolver
+    ) where
+
+import           Control.Exception.Enclosed  (tryIO)
+import           Control.Monad.Catch
+import           Control.Monad.IO.Class
+import           Control.Monad.Logger
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Control
+import qualified Data.ByteString             as S
+import qualified Data.ByteString.Char8       as S8
+import           Data.Either
+import           Data.Map                    (Map)
+import qualified Data.Map                    as Map
+import           Data.Text                   (Text)
+import qualified Data.Text                   as T
+import           Data.Text.Encoding          (decodeUtf8, encodeUtf8)
+import           Path
+import           Stack.Types
+import           System.Directory            (copyFile,
+                                              createDirectoryIfMissing)
+import qualified System.FilePath             as FP
+import           System.IO.Temp
+import           System.Process.Read
+
+cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, MonadReader env m, HasConfig env)
+            => [Path Abs File] -- ^ cabal files
+            -> m (MajorVersion, Map PackageName (Version, Map FlagName Bool))
+cabalSolver cabalfps = withSystemTempDirectory "cabal-solver" $ \dir -> do
+    $logInfo "Trying out the cabal dependency solver as a last resort"
+
+    configLines <- getCabalConfig dir
+    let configFile = dir FP.</> "cabal.config"
+    liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines
+
+    menv <- getMinimalEnvOverride
+    ghcMajorVersion <- getGhcMajorVersion menv
+
+    let args = ("--config-file=" ++ configFile)
+             : "install"
+             : "-v"
+             : "--dry-run"
+             : "--only-dependencies"
+             : "--reorder-goals"
+             : "--max-backjumps=-1"
+             : "--package-db=clear"
+             : "--package-db=global"
+             : map (toFilePath . parent) cabalfps
+    bs <- readProcessStdout Nothing menv "cabal" args
+    let ls = drop 1
+           $ dropWhile (not . T.isPrefixOf "In order, ")
+           $ T.lines
+           $ decodeUtf8 bs
+        (errs, pairs) = partitionEithers $ map parseLine ls
+    if null errs
+        then return (ghcMajorVersion, Map.fromList pairs)
+        else error $ "Could not parse cabal-install output: " ++ show errs
+  where
+    parseLine t0 = maybe (Left t0) Right $ do
+        -- get rid of (new package) and (latest: ...) bits
+        ident':flags' <- Just $ T.words $ T.takeWhile (/= '(') t0
+        PackageIdentifier name version <-
+            parsePackageIdentifierFromString $ T.unpack ident'
+        flags <- mapM parseFlag flags'
+        Just (name, (version, Map.fromList flags))
+    parseFlag t0 = do
+        flag <- parseFlagNameFromString $ T.unpack t1
+        return (flag, enabled)
+      where
+        (t1, enabled) =
+            case T.stripPrefix "-" t0 of
+                Nothing -> (t0, True)
+                Just x -> (x, False)
+
+getGhcMajorVersion :: (MonadLogger m, MonadCatch m, MonadBaseControl IO m, MonadIO m)
+                   => EnvOverride -> m MajorVersion
+getGhcMajorVersion menv = do
+    bs <- readProcessStdout Nothing menv "ghc" ["--numeric-version"]
+    version <- parseVersion $ S8.takeWhile isValid bs
+    return $ getMajorVersion version
+  where
+    isValid c = c == '.' || ('0' <= c && c <= '9')
+
+getCabalConfig :: (MonadReader env m, HasConfig env, MonadIO m, MonadThrow m)
+               => FilePath -- ^ temp dir
+               -> m [Text]
+getCabalConfig dir = do
+    indices <- asks $ configPackageIndices . getConfig
+    remotes <- mapM goIndex indices
+    let cache = T.pack $ "remote-repo-cache: " ++ dir
+    return $ cache : remotes
+  where
+    goIndex index = do
+        src <- configPackageIndex $ indexName index
+        let dstdir = dir FP.</> T.unpack (indexNameText $ indexName index)
+            dst = dstdir FP.</> "00-index.tar"
+        liftIO $ void $ tryIO $ do
+            createDirectoryIfMissing True dstdir
+            copyFile (toFilePath src) dst
+        return $ T.concat
+            [ "remote-repo: "
+            , indexNameText $ indexName index
+            , ":http://0.0.0.0/fake-url"
+            ]

stack.cabal

@@ -43,6 +43,7 @@ library
                      Stack.Path
                      Stack.Repl
                      Stack.Setup
+                     Stack.Solver
                      Stack.Types
                      Stack.Types.Internal
                      Stack.Types.BuildPlan

test/integration/tests/cabal-solver/Main.hs

@@ -0,0 +1,6 @@
+import StackTest
+
+main :: IO ()
+main = do
+    stack ["init", "--use-solver"]
+    stack ["build"]

test/integration/tests/cabal-solver/files/Foo.hs

@@ -0,0 +1 @@
+module Foo where

test/integration/tests/cabal-solver/files/foo.cabal

@@ -0,0 +1,10 @@
+name:                foo
+version:             0.0.0
+synopsis:            foo
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:   Foo
+  build-depends:     base, acme-dont
+  default-language:  Haskell2010