module Stack.Init
( findCabalFiles
, initProject
, InitOpts (..)
, initOptsParser
, readResolver
) where
import Control.Exception (assert)
import Control.Exception.Enclosed (handleIO, catchAny)
import Control.Monad (liftM, when)
import Control.Monad.Catch (MonadMask, throwM)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.IntMap as IntMap
import Data.List (sort)
import Data.List (isSuffixOf)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import qualified Distribution.PackageDescription as C
import Network.HTTP.Client.Conduit (HasHttpManager)
import Options.Applicative
import Options.Applicative.Types (readerAsk)
import Path
import Path.Find
import Path.IO
import Stack.BuildPlan
import Stack.Constants
import Stack.Package
import Stack.Solver
import Stack.Types
import System.Directory (getDirectoryContents)
findCabalFiles :: MonadIO m => Path Abs Dir -> m [Path Abs File]
findCabalFiles dir =
liftIO $ findFiles dir isCabal (not . isIgnored)
where
isCabal path = ".cabal" `isSuffixOf` toFilePath path
isIgnored path = toFilePath (dirname path) `Set.member` ignoredDirs
ignoredDirs :: Set FilePath
ignoredDirs = Set.fromList
[ ".git"
, "dist"
, ".stack-work"
]
initProject :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
=> InitOpts
-> m ()
initProject initOpts = do
currDir <- getWorkingDir
let dest = currDir </> stackDotYaml
dest' = toFilePath dest
exists <- fileExists dest
when exists $ error "Refusing to overwrite existing stack.yaml, please delete before running stack init"
cabalfps <- findCabalFiles currDir
$logInfo $ "Writing default config file to: " <> T.pack dest'
$logInfo $ "Basing on cabal files:"
mapM_ (\path -> $logInfo $ "- " <> T.pack (toFilePath path)) cabalfps
$logInfo ""
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, extraDeps) <- getDefaultResolver cabalfps gpds initOpts
let p = Project
{ projectPackages = pkgs
, projectExtraDeps = extraDeps
, projectFlags = flags
, projectResolver = r
}
pkgs = map toPkg cabalfps
toPkg fp = PackageEntry
{ peValidWanted = Nothing
, peExtraDepMaybe = Nothing
, peLocation = PLFilePath $
case stripDir currDir $ parent fp of
Nothing
| currDir == parent fp -> "."
| otherwise -> assert False $ toFilePath $ parent fp
Just rel -> toFilePath rel
, peSubdirs = []
}
$logInfo $ "Selected resolver: " <> renderResolver r
liftIO $ Yaml.encodeFile dest' p
$logInfo $ "Wrote project config to: " <> T.pack dest'
getSnapshots' :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
=> m (Maybe Snapshots)
getSnapshots' =
liftM Just getSnapshots `catchAny` \e -> do
$logError $
"Unable to download snapshot list, and therefore could " <>
"not generate a stack.yaml file automatically"
$logError $
"This sometimes happens due to missing Certificate Authorities " <>
"on your system. For more information, see:"
$logError ""
$logError " https://github.com/commercialhaskell/stack/issues/234"
$logError ""
$logError "You can try again, or create your stack.yaml file by hand. See:"
$logError ""
$logError " https://github.com/commercialhaskell/stack/wiki/stack.yaml"
$logError ""
$logError $ "Exception was: " <> T.pack (show e)
return Nothing
getDefaultResolver :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
=> [Path Abs File]
-> [C.GenericPackageDescription]
-> InitOpts
-> m (Resolver, Map PackageName (Map FlagName Bool), Map PackageName Version)
getDefaultResolver cabalfps gpds initOpts = do
case ioMethod initOpts of
MethodSnapshot snapPref -> do
msnapshots <- getSnapshots'
names <-
case msnapshots of
Nothing -> return []
Just snapshots -> getRecommendedSnapshots snapshots snapPref
mpair <- findBuildPlan gpds names
case mpair of
Just (snap, flags) ->
return (ResolverSnapshot snap, flags, Map.empty)
Nothing -> throwM $ NoMatchingSnapshot names
MethodResolver resolver -> do
mpair <-
case resolver of
ResolverSnapshot name -> findBuildPlan gpds [name]
ResolverGhc _ -> return Nothing
case mpair of
Just (snap, flags) ->
return (ResolverSnapshot snap, flags, Map.empty)
Nothing -> return (resolver, Map.empty, Map.empty)
MethodSolver -> do
(ghcVersion, extraDeps) <- cabalSolver (map parent cabalfps) []
return
( ResolverGhc ghcVersion
, Map.filter (not . Map.null) $ fmap snd extraDeps
, fmap fst extraDeps
)
getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
=> Snapshots
-> SnapPref
-> m [SnapName]
getRecommendedSnapshots snapshots pref = do
existing <-
liftM (reverse . sort . mapMaybe (parseSnapName . T.pack)) $
snapshotsDir >>=
liftIO . handleIO (const $ return [])
. getDirectoryContents . toFilePath
let isLTS LTS{} = True
isLTS Nightly{} = False
isNightly Nightly{} = True
isNightly LTS{} = False
names = nubOrd $ concat
[ take 2 $ filter isLTS existing
, take 2 $ filter isNightly existing
, map (uncurry LTS)
(take 2 $ reverse $ IntMap.toList $ snapshotsLts snapshots)
, [Nightly $ snapshotsNightly snapshots]
]
namesLTS = filter isLTS names
namesNightly = filter isNightly names
case pref of
PrefNone -> return names
PrefLTS -> return $ namesLTS ++ namesNightly
PrefNightly -> return $ namesNightly ++ namesLTS
data InitOpts = InitOpts
{ ioMethod :: !Method
}
data SnapPref = PrefNone | PrefLTS | PrefNightly
data Method = MethodSnapshot SnapPref | MethodResolver Resolver | MethodSolver
initOptsParser :: Parser InitOpts
initOptsParser =
InitOpts <$> method
where
method = solver
<|> (MethodResolver <$> resolver)
<|> (MethodSnapshot <$> snapPref)
solver =
flag' MethodSolver
(long "solver" <>
help "Use a dependency solver to determine dependencies")
snapPref =
flag' PrefLTS
(long "prefer-lts" <>
help "Prefer LTS snapshots over Nightly snapshots") <|>
flag' PrefNightly
(long "prefer-nightly" <>
help "Prefer Nightly snapshots over LTS snapshots") <|>
pure PrefNone
resolver = option readResolver
(long "resolver" <>
metavar "RESOLVER" <>
help "Use the given resolver, even if not all dependencies are met")
readResolver :: ReadM Resolver
readResolver = do
s <- readerAsk
case parseResolver $ T.pack s of
Left e -> readerError $ show e
Right x -> return x
nubOrd :: Ord a => [a] -> [a]
nubOrd =
go Set.empty
where
go _ [] = []
go s (x:xs)
| x `Set.member` s = go s xs
| otherwise = x : go (Set.insert x s) xs